diff --git a/djinn.cabal b/djinn.cabal --- a/djinn.cabal +++ b/djinn.cabal @@ -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 diff --git a/src/Djinn.hs b/src/Djinn.hs --- a/src/Djinn.hs +++ b/src/Djinn.hs @@ -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 = ", "Add a data type", pData), ("class where ", "Add a class", pClass), (" :: ", "Add to environment", pAdd), + ("? :: ", "Query", pQuery'), (" ? ", "Query", pQuery), + ("?instance ","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 diff --git a/src/HTypes.hs b/src/HTypes.hs --- a/src/HTypes.hs +++ b/src/HTypes.hs @@ -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 ------------------------------- diff --git a/src/Help.hs b/src/Help.hs --- a/src/Help.hs +++ b/src/Help.hs @@ -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\