3 classes for Symbol

lib/Data/TypeLits.hs

@@ -3,15 +3,29 @@ module Data.TypeLits(
   Nat,
   KnownNat(..),
   KnownSymbol(..),
+  SymbolEq,
+  ConcatSymbol,
+  HeadSymbol
   ) where
 import qualified Prelude()
 import Primitives
 import Data.Char_Type
 import Data.Integer
 import {-# SOURCE #-} Data.Typeable
 
+-- Special classes solved by the typechecker.
+-- An instance of one of these classes would be useless.
+
 class KnownNat (n :: Nat) where
   natVal :: forall (proxy :: Nat -> Type) . proxy n -> Integer
 
 class KnownSymbol (s :: Symbol) where
   symbolVal :: forall (proxy :: Symbol -> Type) . proxy s -> String
+
+-- Tests two litteral Symbols equality and returns "True" or "False".
+class SymbolEq (s :: Symbol) (t :: Symbol) (b :: Symbol) | s t -> b
+
+class ConcatSymbol (s :: Symbol) (t :: Symbol) (st :: Symbol) | s t -> st, st s -> t, st t -> s
+
+class HeadSymbol (h :: Symbol) (t :: Symbol) (s :: Symbol)
+  | h t -> s, s -> h t

src/MicroHs/Names.hs

@@ -100,6 +100,15 @@ nameKnownNat = "Data.TypeLits.KnownNat"
 nameKnownSymbol :: String
 nameKnownSymbol = "Data.TypeLits.KnownSymbol"
 
+nameSymbolEq :: String
+nameSymbolEq = "Data.TypeLits.SymbolEq"
+
+nameConcatSymbol :: String
+nameConcatSymbol = "Data.TypeLits.ConcatSymbol"
+
+nameHeadSymbol :: String
+nameHeadSymbol = "Data.TypeLits.HeadSymbol"
+
 nameDataTypeableTypeable :: String
 nameDataTypeableTypeable = "Data.Typeable.Typeable"
 identDataTypeableTypeable :: Ident

src/MicroHs/TypeCheck.hs

@@ -3592,6 +3592,9 @@ solvers =
   , ((== mkIdent nameTypeEq),      solveTypeEq)       -- handle equality constraints, i.e. (t1 ~ t2)
   , ((== mkIdent nameKnownNat),    solveKnownNat)     -- KnownNat 123 constraints
   , ((== mkIdent nameKnownSymbol), solveKnownSymbol)  -- KnownSymbol "abc" constraints
+  , ((== mkIdent nameSymbolEq),    solveSymbolEq)     -- SymbolEq "hello" "h3ll0" "False"
+  , ((== mkIdent nameConcatSymbol),solveConcatSymbol) -- ConcatSymbol "ab" "cd" "abcd" constraints
+  , ((== mkIdent nameHeadSymbol),  solveHeadSymbol)   -- HeadSymbol "h" "tail" "htail" ("h" always 1 character) contraints
   , ((== mkIdent nameCoercible),   solveCoercible)    -- Coercible a b constraints
   , (const True,                   solveInst)         -- handle constraints with instances
   ]
@@ -3777,6 +3780,72 @@ solveKnownSymbol :: SolveOne
 solveKnownSymbol loc iCls [e@(ELit _ (LStr _))] = mkConstDict loc iCls e
 solveKnownSymbol loc iCls ts = solveInst loc iCls ts  -- look for a dict argument
 
+solveSymbolEq :: SolveOne
+solveSymbolEq loc iCls [s, t, b] =
+  case (s, t) of
+    (ELit _ (LStr sStr), ELit _ (LStr tStr)) ->
+      let result = if sStr == tStr then "True" else "False"
+      in case b of
+           ELit _ (LStr bStr)
+             | bStr == result -> return $ Just (ETuple [], [], [])
+             | otherwise      -> return Nothing
+           _ | isEUVar b -> return $ Just (ETuple [], [], [(loc, b, ELit loc (LStr result))])
+             | otherwise -> return Nothing
+    _ -> solveInst loc iCls [s, t, b]   -- s or t not concrete yet : we defer
+solveSymbolEq loc iCls ts = solveInst loc iCls ts
+
+solveConcatSymbol :: SolveOne
+solveConcatSymbol loc iCls [s, t, st] =
+  case (getLit s, getLit t, getLit st) of
+    (Just sStr, Just tStr, _) ->
+      unifyOrCheck loc st (sStr ++ tStr)
+    (Just sStr, Nothing, Just stStr)
+      | sStr `isPrefixOf` stStr -> unifyOrCheck loc t (drop (length sStr) stStr)
+      | otherwise -> tcError loc $ "ConcatSymbol: " ++ show stStr
+                                  ++ " does not start with " ++ show sStr
+    (Nothing, Just tStr, Just stStr)
+      | tStr `isSuffixOf` stStr -> unifyOrCheck loc s (take (length stStr - length tStr) stStr)
+      | otherwise -> tcError loc $ "ConcatSymbol: " ++ show stStr
+                                  ++ " does not end with " ++ show tStr
+    _ -> solveInst loc iCls [s, t, st]   -- not enough info : we defer
+  where
+    getLit (ELit _ (LStr x)) = Just x
+    getLit _                 = Nothing
+    unifyOrCheck l ty target = case ty of
+      ELit _ (LStr actual) | actual == target -> return $ Just (ETuple [], [], [])
+                            | otherwise -> tcError l $ "ConcatSymbol mismatch"
+      _ | isEUVar ty -> return $ Just (ETuple [], [], [(l, ty, ELit l (LStr target))])
+        | otherwise  -> return Nothing
+solveConcatSymbol loc iCls ts = solveInst loc iCls ts
+
+solveHeadSymbol :: SolveOne
+-- Case 1 : s already known -> we split a head (1 character) and a tail
+solveHeadSymbol loc iCls [h, t, s@(ELit _ (LStr sStr))]
+  | null sStr = return Nothing   -- empty Symbol has neither head nor tail
+  | otherwise = do
+      let hStr = take 1 sStr
+          tStr = drop 1 sStr
+          check ty target = case ty of
+            ELit _ (LStr actual)
+              | actual == target -> Right []
+              | otherwise        -> Left actual
+            _ | isEUVar ty -> Right [(loc, ty, ELit loc (LStr target))]
+              | otherwise  -> Right []
+      case (check h hStr, check t tStr) of
+        (Left actual, _) ->
+          tcError loc $ "HeadSymbol: expected head " ++ show hStr ++ ", received " ++ show actual
+        (_, Left actual) ->
+          tcError loc $ "HeadSymbol: expected tail " ++ show tStr ++ ", received " ++ show actual
+        (Right is1, Right is2) -> return $ Just (ETuple [], [], is1 ++ is2)
+-- Case 2 : h and t already known (and s not litteral, otherwise case 1 should match)
+solveHeadSymbol loc iCls [h@(ELit _ (LStr hStr)), t@(ELit _ (LStr tStr)), s]
+  | length hStr /= 1 =
+      tcError loc $ "HeadSymbol: head should be 1 character, received " ++ show hStr
+  | isEUVar s = return $ Just (ETuple [], [], [(loc, s, ELit loc (LStr (hStr ++ tStr)))])
+  | otherwise = return Nothing
+-- not enough info : we defer
+solveHeadSymbol loc iCls ts = solveInst loc iCls ts
+
 mkConstDict :: SLoc -> Ident -> Expr -> T (Maybe (Expr, [Goal], [Improve]))
 mkConstDict loc iCls e = do
   let res = EApp (EVar $ mkClassConstructor iCls) fcn

tests/ConcatSymbol.hs

@@ -0,0 +1,29 @@
+module ConcatSymbol where
+import Data.Proxy
+import Data.TypeLits
+
+testSuccess :: ConcatSymbol "ab" "cd" "abcd" => Bool
+testSuccess = True
+
+testConcat :: ConcatSymbol s1 s2 s3 => Proxy s1 -> Proxy s2 -> Proxy s3
+testConcat _ _ = Proxy
+
+testPrefix :: ConcatSymbol s1 s2 s3 => Proxy s3 -> Proxy s2 -> Proxy s1
+testPrefix _ _ = Proxy
+
+testSuffix :: ConcatSymbol s1 s2 s3 => Proxy s3 -> Proxy s1 -> Proxy s2
+testSuffix _ _ = Proxy
+
+testChain ::
+  ( ConcatSymbol s1 s2 s3
+  , ConcatSymbol s3 s4 s7)
+  => Proxy s1 -> Proxy s2 -> Proxy s4 -> Proxy s7
+testChain _ _ _ = Proxy
+
+main = do
+  putStrLn $ show testSuccess
+  putStrLn $ symbolVal $ testConcat (Proxy :: Proxy "ab") (Proxy :: Proxy "cd")
+  putStrLn $ symbolVal $ testPrefix (Proxy :: Proxy "abcd") (Proxy :: Proxy "cd")
+  putStrLn $ symbolVal $ testSuffix (Proxy :: Proxy "abcd") (Proxy :: Proxy "ab")
+  putStrLn $ symbolVal $
+    testChain (Proxy :: Proxy "ab") (Proxy :: Proxy "cd") (Proxy :: Proxy "ef")

tests/ConcatSymbol.ref

@@ -0,0 +1,5 @@
+True
+abcd
+ab
+cd
+abcdef

tests/HeadSymbolEq.hs

@@ -0,0 +1,114 @@
+module HeadSymbolEq where
+
+import Data.Proxy
+import Data.TypeLits (Symbol, KnownSymbol, symbolVal, ConcatSymbol, HeadSymbol, SymbolEq)
+
+--------------------------------------------------------------------------------
+-- Specifier : Lit wraps a Symbol.
+--------------------------------------------------------------------------------
+
+data D -- digit
+data S -- string
+data Lit (lit :: Symbol)
+
+class Specifier s
+instance Specifier D
+instance Specifier S
+instance (KnownSymbol lit) => Specifier (Lit lit)
+
+--------------------------------------------------------------------------------
+-- FList : lists the formats.
+--------------------------------------------------------------------------------
+
+data FNil
+data FCons s fl
+
+class FList fl
+instance FList FNil
+instance (Specifier s, FList fl) => FList (FCons s fl)
+
+--------------------------------------------------------------------------------
+-- FormatF : splits the %d / %s formats
+--------------------------------------------------------------------------------
+
+class (FList format) => FormatF format fun | format -> fun where
+  formatF :: Proxy format -> String -> fun
+
+instance FormatF FNil String where
+  formatF _ = id
+
+instance (FormatF rest fun)
+  => FormatF (FCons D rest) (Int -> fun) where
+  formatF _ str = \i -> formatF (Proxy :: Proxy rest) (str ++ show i)
+
+instance (FormatF rest fun)
+  => FormatF (FCons S rest) (String -> fun) where
+  formatF _ str = \s -> formatF (Proxy :: Proxy rest) (str ++ s)
+
+instance (KnownSymbol lit, FormatF rest fun)
+  => FormatF (FCons (Lit lit) rest) fun where
+  formatF _ str
+    = formatF (Proxy :: Proxy rest) (str ++ symbolVal (Proxy :: Proxy lit))
+
+--------------------------------------------------------------------------------
+-- MatchFmt
+--------------------------------------------------------------------------------
+
+class (Specifier out) => MatchFmt (head :: Symbol) out | head -> out
+instance MatchFmt "d" D
+instance MatchFmt "s" S
+
+--------------------------------------------------------------------------------
+-- Parse : uses SymbolEq -> "True"/"False" to avoid instance overlappings.
+--------------------------------------------------------------------------------
+
+class (FList format) => Parse (string :: Symbol) format | string -> format
+instance (SymbolEq string "" isEmpty, ParseC isEmpty string format)
+  => Parse string format
+
+class (FList out) => ParseC (isEmpty :: Symbol) (string :: Symbol) out | isEmpty string -> out
+
+instance ParseC "True" string (FCons (Lit "") FNil)
+
+instance (HeadSymbol h t string, Match h t out)
+  => ParseC "False" string out
+
+--------------------------------------------------------------------------------
+-- Match  : uses SymbolEq also.
+--------------------------------------------------------------------------------
+
+class (FList out) => Match (h :: Symbol) (t :: Symbol) out | h t -> out
+instance (SymbolEq h "%" isPct, MatchC isPct h t out)
+  => Match h t out
+
+class (FList out) => MatchC (isPct :: Symbol) (h :: Symbol) (t :: Symbol) out
+  | isPct h t -> out
+
+-- '%' : on decompose t pour recuperer le caractere de specification (h2)
+-- et le reste (t2)
+instance (HeadSymbol h2 t2 t, MatchFmt h2 spec, Parse t2 rest)
+  => MatchC "True" h t (FCons (Lit "") (FCons spec rest))
+
+-- caractere ordinaire : accumule via ConcatSymbol (h prefixe acc)
+instance (FList r, KnownSymbol acc', ConcatSymbol h acc acc', Parse t (FCons (Lit acc) r))
+  => MatchC "False" h t (FCons (Lit acc') r)
+
+--------------------------------------------------------------------------------
+-- Format
+--------------------------------------------------------------------------------
+
+class Format (string :: Symbol) fun | string -> fun where
+  format :: Proxy string -> fun
+
+instance (Parse string format, FormatF format fun)
+  => Format string fun where
+  format _ = formatF (Proxy :: Proxy format) ""
+
+--------------------------------------------------------------------------------
+-- Exemple
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+  let formatted = format (Proxy :: Proxy "Hi %s! You are %d") "Bill" 12
+  putStrLn formatted -- "Hi Bill! You are 12"

tests/HeadSymbolEq.ref

@@ -0,0 +1 @@
+Hi Bill! You are 12

tests/Makefile

@@ -125,6 +125,8 @@ test:
 	$(TMHS) QualString && $(EVAL) > QualString.out && diff QualString.ref QualString.out
 	$(TMHS) MD5        && $(EVAL) > MD5.out        && diff MD5.ref MD5.out
 	$(TMHS) Interpolate && $(EVAL) > Interpolate.out && diff Interpolate.ref Interpolate.out
+	$(TMHS) ConcatSymbol   && $(EVAL) > ConcatSymbol.out 	&& diff ConcatSymbol.ref ConcatSymbol.out
+	$(TMHS) HeadSymbolEq   && $(EVAL) > HeadSymbolEq.out	&& diff HeadSymbolEq.ref HeadSymbolEq.out
 	$(TMHS) DerivingBuiltin
 
 testforimp: