djinn 2009.2.8 → 2009.9.3
raw patch · 4 files changed
+75/−18 lines, 4 files
Files
- djinn.cabal +2/−2
- src/Djinn.hs +55/−14
- src/HTypes.hs +8/−2
- src/Help.hs +10/−0
djinn.cabal view
@@ -1,5 +1,5 @@ Name: djinn-Version: 2009.2.8+Version: 2009.9.3 License: BSD3 License-file: LICENSE Author: Lennart Augustsson@@ -10,7 +10,7 @@ Homepage: http://www.augustsson.net/Darcs/Djinn/ Synopsis: Generate Haskell code from a type Build-type: Simple-Build-Depends: base >= 3 && < 4, mtl, editline, pretty, array, containers+Build-Depends: base >= 3 && < 4, mtl, editline -any, pretty, array, containers Executable: djinn Main-Is: Djinn.hs
src/Djinn.hs view
@@ -22,7 +22,7 @@ --import Debug.Trace version :: String-version = "version 2009-02-08"+version = "version 2009-09-04" main :: IO () main = do@@ -78,15 +78,20 @@ cutOff = 200 } where syns = either (const $ error "Bad initial environment") id $ htCheckEnv $ reverse [- ("()", ([], HTUnion [("()",[])], undefined)),- ("Either", (["a","b"], HTUnion [("Left", [HTVar "a"]), ("Right", [HTVar "b"])], undefined)),- ("Maybe", (["a"], HTUnion [("Nothing", []), ("Just", [HTVar "a"])], undefined)),- ("Bool", ([], HTUnion [("False", []), ("True", [])], undefined)),- ("Void", ([], HTUnion [], undefined)),- ("Not", (["x"], htNot "x", undefined))+ ("()", ([], HTUnion [("()",[])], undefined)),+ ("Either", (["a","b"], HTUnion [("Left", [a]), ("Right", [b])], undefined)),+ ("Maybe", (["a"], HTUnion [("Nothing", []), ("Just", [a])], undefined)),+ ("Bool", ([], HTUnion [("False", []), ("True", [])], undefined)),+ ("Void", ([], HTUnion [], undefined)),+ ("Not", (["x"], htNot "x", undefined)) ]- clss = [("Eq", (["a"], [("==", a `HTArrow` (a `HTArrow` HTCon "Bool"))]))]+ clss = [("Eq", (["a"], [("==", a `HTArrow` (a `HTArrow` HTCon "Bool"))])),+ ("Monad", (["m"], [("return", a `HTArrow` ma),+ (">>=", ma `HTArrow` ((a `HTArrow` mb) `HTArrow` mb))]))+ ] where ma = HTApp m a; mb = HTApp m b a = HTVar "a"+ b = HTVar "b"+ m = HTVar "m" inIt :: State -> IO (String, State)@@ -113,7 +118,8 @@ type ClassDef = (HSymbol, ([HSymbol], [Method])) data Cmd = Help Bool | Quit | Add HSymbol HType | Query HSymbol [Context] HType | Del HSymbol | Load HSymbol | Noop | Env |- Type (HSymbol, ([HSymbol], HType, HKind)) | Set (State -> State) | Clear | Class ClassDef+ Type (HSymbol, ([HSymbol], HType, HKind)) | Set (State -> State) | Clear | Class ClassDef |+ QueryInstance [Context] HSymbol [HType] pCmd :: ReadP Cmd pCmd = do@@ -149,7 +155,7 @@ runCmd s (Add i t) = case htCheckType (synonyms s) t of Left msg -> do putStrLn $ "Error: " ++ msg; return (False, s)- Right _ -> return (False, s { axioms = (i, t) : axioms s })+ Right _ -> return (False, s { axioms = (i, t) : filter ((/= i) . fst) (axioms s) }) runCmd _ Clear = return (False, startState) runCmd s (Del i) = @@ -172,12 +178,25 @@ runCmd s (Set f) = return (False, f s) runCmd s (Query i ctx g) =- query s i ctx g+ query True s i ctx g runCmd s (Class c) = do return (False, s { classes = c : classes s })+runCmd s (QueryInstance ctx cls ts) =+ case lookup cls (classes s) of+ Nothing -> do putStrLn $ "No class " ++ cls; return (False, s)+ Just (vs, ms) -> if length ts /= length vs then do putStrLn "Wrong number of type arguments"; return (False, s) else do+ let sctx = if null ctx then "" else showContexts ctx ++ " => "+ let r = zip vs ts+ method (i, t) = do+-- print (substHT r t)+ putStr " "+ query False s i ctx (substHT r t)+ putStrLn $ "instance " ++ sctx ++ show (foldl HTApp (HTCon cls) ts) ++ " where"+ mapM_ method ms+ return (False, s) -query :: State -> String -> [Context] -> HType -> IO (Bool, State)-query s i ctx g =+query :: Bool -> State -> String -> [Context] -> HType -> IO (Bool, State)+query prType s i ctx g = case htCheckType (synonyms s) g >> mapM (ctxLookup (classes s)) ctx of Left msg -> do putStrLn $ "Error: " ++ msg; return (False, s) Right mss -> do@@ -206,7 +225,7 @@ pr = putStrLn . hPrClause sctx = if null ctx then "" else showContexts ctx ++ " => " when (debug s) $ putStrLn ("+++ " ++ show (head ps))- putStrLn $ prHSymbolOp i ++ " :: " ++ sctx ++ show g+ when prType $ putStrLn $ prHSymbolOp i ++ " :: " ++ sctx ++ show g pr e when (multi s) $ mapM_ (\ x -> putStrLn "-- or" >> pr x) es return (False, s)@@ -264,7 +283,9 @@ ("data <sym> <vars> = <datatype>", "Add a data type", pData), ("class <sym> <vars> where <methods>", "Add a class", pClass), ("<sym> :: <type>", "Add to environment", pAdd),+ ("? <sym> :: <type>", "Query", pQuery'), ("<sym> ? <type>", "Query", pQuery),+ ("?instance <sym> <types>","Query instance", pQueryInstance), ("", "", return Noop) ] @@ -305,6 +326,26 @@ t <- pHType optional $ schar ';' return $ Query i c t++pQuery' :: ReadP Cmd+pQuery' = do+ schar '?'+ i <- pHSymbolOp+ sstring "::"+ c <- option [] pContext+ t <- pHType+ optional $ schar ';'+ return $ Query i c t++pQueryInstance :: ReadP Cmd+pQueryInstance = do+ schar '?'+ sstring "instance"+ c <- option [] pContext+ cls <- pHSymbol True+ ts <- many1 pHTAtom+ optional $ schar ';'+ return $ QueryInstance c cls ts pContext :: ReadP [Context] pContext = do
src/HTypes.hs view
@@ -45,6 +45,7 @@ showsPrec _ (HTApp (HTCon "[]") t) = showString "[" . showsPrec 0 t . showString "]" showsPrec p (HTApp f a) = showParen (p > 2) $ showsPrec 2 f . showString " " . showsPrec 3 a showsPrec _ (HTVar s) = showString s+ showsPrec _ (HTCon s@(c:_)) | not (isAlpha c) = showParen True $ showString s showsPrec _ (HTCon s) = showString s showsPrec _ (HTTuple ss) = showParen True $ f ss where f [] = error "showsPrec HType"@@ -91,7 +92,9 @@ return $ HTCon "()" pHTCon :: ReadP HType-pHTCon = pHSymbol True >>= return . HTCon+pHTCon = (pHSymbol True >>= return . HTCon)+ ++++ do schar '('; schar '-'; schar '>'; schar ')'; return (HTCon "->") pHTVar :: ReadP HType pHTVar = pHSymbol False >>= return . HTVar@@ -171,7 +174,7 @@ expandSyn _ _ _ = Nothing substHT :: [(HSymbol, HType)] -> HType -> HType-substHT r (HTApp f a) = HTApp (substHT r f) (substHT r a)+substHT r (HTApp f a) = hTApp (substHT r f) (substHT r a) substHT r t@(HTVar v) = case lookup v r of Nothing -> t@@ -182,6 +185,9 @@ substHT r (HTUnion (ctss)) = HTUnion [ (c, map (substHT r) ts) | (c, ts) <- ctss ] substHT _ t@(HTAbstract _ _) = t +hTApp :: HType -> HType -> HType+hTApp (HTApp (HTCon "->") a) b = HTArrow a b+hTApp a b = HTApp a b -------------------------------
src/Help.hs view
@@ -168,6 +168,16 @@ \polymorphic functions, so classes where the methods are polymorphic\n\ \do not work as expected.\n\ \\n\+\It is also possible to query for an instance of a class, which is executed\n\+\as q query for each of the methods, e.g.,\n\+\ Djinn> ?instance Monad Maybe\n\+\ instance Monad Maybe where\n\+\ return = Just\n\+\ (>>=) a b =\n\+\ case a of\n\+\ Nothing -> Nothing\n\+\ Just c -> b c\n\+\\n\ \\n\ \Theory\n\ \======\n\