[
{
"path": ".gitignore",
"content": ".stack-work\n"
},
{
"path": "Dockerfile",
"content": "FROM frolvlad/alpine-gcc as base\n\nRUN apk add --no-cache ghc curl git\n\nRUN curl -L https://github.com/nh2/stack/releases/download/v1.6.5/stack-prerelease-1.9.0.1-x86_64-unofficial-fully-static-musl > /usr/bin/stack\n\nRUN chmod +x /usr/bin/stack\n\nRUN git clone https://github.com/chrisdone/duet.git --depth 1 && cd duet && git checkout 186d4dbf85f23e28862fce7e8160adddfdb8d36f\nRUN cd duet && stack update\nRUN apk add --no-cache zlib-dev\nRUN cd duet && stack build --system-ghc --dependencies-only\n\nRUN cd duet && git pull && git checkout f6c19caf0cb9182dae665ff47c68c27001763fd9\nRUN cd duet && stack install --system-ghc --fast\n\nFROM alpine:3.9\nRUN apk add --no-cache gmp libffi\n\nCOPY --from=base /root/.local/bin/duet /usr/bin/duet\n\nENTRYPOINT [\"duet\"]\n"
},
{
"path": "LICENSE.md",
"content": "*Duet* is Copyright (c) Chris Done 2017.\n\n*Typing Haskell in Haskell*, which provides the groundwork for Duet's\ntype system, is Copyright (c) Mark P Jones and the Oregon Graduate\nInstitute of Science and Technology, 1999-2000.\n\nAll rights reserved, and is distributed as free software under the\nfollowing license.\n\nRedistribution and use in source and binary forms, with or\nwithout modification, are permitted provided that the following\nconditions are met:\n\n- Redistributions of source code must retain the above copyright\nnotice, this list of conditions and the following disclaimer.\n\n- Redistributions in binary form must reproduce the above\ncopyright notice, this list of conditions and the following\ndisclaimer in the documentation and/or other materials provided\nwith the distribution.\n\n- Neither name of the copyright holders nor the names of its\ncontributors may be used to endorse or promote products derived\nfrom this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE\nCONTRIBUTORS \"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES,\nINCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\nMERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE\nCONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\nSPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT\nNOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\nLOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,\nSTRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)\nARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF\nADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n"
},
{
"path": "README.md",
"content": "# 
Duet\n\nA tiny language, a subset of Haskell (with type classes) aimed at aiding teachers teach Haskell\n\n## Run\n\nRunning code in Duet literally performs one substitution step at\ntime. For example, evaluating `(\\x -> x + 5) (2 * 3)`, we get:\n\n``` haskell\n$ duet run demo.hs\n(\\x -> x + 5) (2 * 3)\n(2 * 3) + 5\n6 + 5\n11\n```\n\nNote that this demonstrates basic argument application and non-strictness.\n\n## Docker run\n\nRun with the docker distribution, to easily run on any platform:\n\n $ docker run -it -v $(pwd):/w -w /w chrisdone/duet run foo.hs\n\n(This should work on Linux, OS X or Windows PowerShell.)\n\nThe image is about 11MB, so it's quick to download.\n\n## Differences from Haskell\n\nSee also the next section for a complete example using all the\navailable syntax.\n\n* Duet is non-strict, but is not lazy. There is no sharing and no\n thunks.\n* No `module` or `import` module system whatsoever.\n* No `let` syntax, no parameters in definitions e.g. `f x = ..` you\n must use a lambda. Representing `let` in the stepper presents a\n design challenge not currently met.\n* Kinds `*` are written `Type`: e.g. `class Functor (f :: Type -> Type)`.\n* Kind inference is not implemented, so if you want a kind other than\n `Type` (aka `*` in Haskell), you have to put a kind signature on the\n type variable.\n* Indentation is stricter, a case's alts must be at a column larger\n than the `case`.\n* Duet does not have `seq`, but it does have bang patterns in\n cases. `case x of !x -> ..` is a perfectly legitimate way to force a\n value.\n* Infix operators are stricter: an infix operator must have spaces\n around it. You **cannot** have more than one operator without\n parentheses, therefore operator precedence does not come into play\n in Duet (this is intentional). This also permits you to write `-5`\n without worrying about where it rests.\n* Superclasses are not supported.\n* Operator definitions are not supported.\n* There is only `Integer` and `Rational` number types: they are\n written as `1` or `1.0`.\n* Any `_` or `_foo` means \"hole\" and the interpreter does not touch\n them, it continues performing rewrites without caring. This is good\n for teaching.\n* There is no standard `Prelude`. The only defined base types are:\n * String\n * Char\n * Integer\n * Rational\n * Bool\n* You don't need a `Show` instance to inspect values; the interpreter\n shows them as they are, including lambdas.\n\nView `examples/syntax-buffet.hs` for an example featuring all the\nsyntax supported in Duet.\n\n## Print built-in types and classes\n\nTo print all types (primitive or otherwise), run:\n\n $ duet types\n\nExample output:\n\n```haskell\ndata Bool\n = True\n | False\ndata String\ndata Integer\ndata Rational\n```\n\nFor classes and the instances of each class:\n\n $ duet classes\n\nExample output:\n\n```haskell\nclass Num a where\n plus :: forall a. (a -> a -> a)\n times :: forall a. (a -> a -> a)\ninstance Num Rational\ninstance Num Integer\n\nclass Neg a where\n negate :: forall a. (a -> a -> a)\n subtract :: forall a. (a -> a -> a)\n abs :: forall a. (a -> a)\ninstance Neg Rational\ninstance Neg Integer\n\nclass Fractional a where\n divide :: forall a. (a -> a -> a)\n recip :: forall a. (a -> a)\ninstance Fractional Rational\n\nclass Monoid a where\n append :: forall a. (a -> a -> a)\n empty :: forall a. a\ninstance Monoid String\n\nclass Slice a where\n drop :: forall a. (Integer -> a -> a)\n take :: forall a. (Integer -> a -> a)\ninstance Slice String\n```\n\n## String operations\n\nStrings are provided as packed opaque literals. You can unpack them\nvia the `Slice` class:\n\n```haskell\nclass Slice a where\n drop :: Integer -> a -> a\n take :: Integer -> a -> a\n```\n\nYou can append strings using the `Monoid` class:\n\n```haskell\nclass Monoid a where\n append :: a -> a -> a\n empty :: a\n```\n\nThe `String` type is an instance of these classes.\n\n``` haskell\nmain = append (take 2 (drop 7 \"Hello, World!\")) \"!\"\n```\n\nEvaluates strictly because it's a primop:\n\n``` haskell\nappend (take 2 (drop 7 \"Hello, World!\")) \"!\"\nappend (take 2 \"World!\") \"!\"\nappend \"Wo\" \"!\"\n\"Wo!\"\n```\n\nYou can use this type and operations to teach parsers.\n\n## I/O\n\nBasic terminal input/output is supported.\n\nFor example,\n\n $ duet run examples/terminal.hs --hide-steps\n Please enter your name:\n Chris\n Hello, Chris\n\nAnd with steps:\n\n $ duet run examples/terminal.hs\n PutStrLn \"Please enter your name: \" (GetLine (\\line -> PutStrLn (append \"Hello, \" line) (Pure 0)))\n Please enter your name:\n GetLine (\\line -> PutStrLn (append \"Hello, \" line) (Pure 0))\n Chris\n (\\line -> PutStrLn (append \"Hello, \" line) (Pure 0)) \"Chris\"\n PutStrLn (append \"Hello, \" \"Chris\") (Pure 0)\n Hello, Chris\n Pure 0\n\nHow does this work? Whenever the following code is seen in the\nstepper:\n\n```haskell\nPutStrLn \"Please enter your name: \" \n```\n\nThe string is printed to stdout with `putStrLn`, and the `next`\nexpression is stepped next.\n\nWhenever the following code is seen:\n\n``` haskell\nGetLine (\\line -> )\n```\n\nThe stepper runs `getLine` and feeds the resulting string into the\nstepper as:\n\n```haskell\n(\\line -> ) \"The line\"\n```\n\nThis enables one to write an example program like this:\n\n``` haskell\ndata Terminal a\n = GetLine (String -> Terminal a)\n | PutStrLn String (Terminal a)\n | Pure a\n\nmain =\n PutStrLn\n \"Please enter your name: \"\n (GetLine (\\line -> PutStrLn (append \"Hello, \" line) (Pure 0)))\n```\n"
},
{
"path": "app/Main.hs",
"content": "{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- |\n\nimport Control.Monad.Catch\nimport Control.Monad.Logger\nimport Control.Monad.Supply\nimport Control.Monad.Writer\nimport qualified Data.Map.Strict as M\nimport Data.Semigroup ((<>))\nimport Duet.Context\nimport Duet.Errors\nimport Duet.Infer\nimport Duet.Parser\nimport Duet.Printer\nimport Duet.Renamer\nimport Duet.Setup\nimport Duet.Simple\nimport Duet.Stepper\nimport Duet.Types\nimport Options.Applicative.Simple\nimport System.IO\n\ndata Run = Run\n { runInputFile :: FilePath\n , runMainIs :: String\n , runConcise :: Bool\n , runNumbered :: Bool\n , runSteps :: Maybe Integer\n , runHideSteps :: Bool\n } deriving (Show)\n\nmain :: IO ()\nmain = do\n hSetBuffering stdout LineBuffering\n hSetBuffering stdin LineBuffering\n ((), cmd) <-\n simpleOptions\n \"1.0\"\n \"Duet interpreter\"\n \"This is the interpreter for the Duet mini-Haskell educational language\"\n (pure ())\n (do addCommand \"types\" \"Print types in scope\" runTypesPrint (pure ())\n addCommand \"classes\" \"Print types in scope\" runClassesPrint (pure ())\n addCommand\n \"run\"\n \"Run the given program source\"\n runProgram\n (Run <$>\n strArgument\n (metavar \"FILEPATH\" <> help \"The .hs file to interpret\") <*>\n strOption\n (long \"main\" <> metavar \"NAME\" <> help \"The main value to run\" <>\n value \"main\") <*>\n flag False True (long \"concise\" <> help \"Concise view\") <*>\n flag False True (long \"numbered\" <> help \"Number outputs\") <*>\n optional\n (option\n auto\n (long \"steps\" <> short 'n' <> metavar \"steps\" <>\n help \"Maximum number of steps to run (default: unlimited)\")) <*>\n flag\n False\n True\n (long \"hide-steps\" <> help \"Do not print the steps to stdout\")))\n cmd\n\nrunTypesPrint :: () -> IO ()\nrunTypesPrint _ = do\n builtins <- evalSupplyT (setupEnv mempty []) [1 ..]\n putStrLn\n (printDataType\n defaultPrint\n (builtinsSpecialTypes builtins)\n (specialTypesBool (builtinsSpecialTypes builtins)))\n when\n False\n (putStrLn\n (printTypeConstructorOpaque\n defaultPrint\n (specialTypesChar (builtinsSpecialTypes builtins))))\n putStrLn\n (printTypeConstructorOpaque\n defaultPrint\n (specialTypesString (builtinsSpecialTypes builtins)))\n putStrLn\n (printTypeConstructorOpaque\n defaultPrint\n (specialTypesInteger (builtinsSpecialTypes builtins)))\n putStrLn\n (printTypeConstructorOpaque\n defaultPrint\n (specialTypesRational (builtinsSpecialTypes builtins)))\n where\n printTypeConstructorOpaque p = (\"data \" ++) . printTypeConstructor p\n\nrunClassesPrint :: () -> IO ()\nrunClassesPrint _ = do\n builtins <- evalSupplyT (setupEnv mempty []) [1 ..]\n mapM_\n (putStrLn . (++ \"\\n\") . printClass defaultPrint (builtinsSpecialTypes builtins))\n (M.elems (builtinsTypeClasses builtins))\n\nrunProgram :: Run -> IO ()\nrunProgram run@Run {..} = do\n catch\n (catch\n (runNoLoggingT\n (evalSupplyT\n (do decls <- liftIO (parseFile runInputFile)\n (binds, ctx) <- createContext decls\n things <-\n execWriterT\n (runStepperIO\n run\n runSteps\n ctx\n (fmap (fmap typeSignatureA) binds)\n runMainIs)\n pure things)\n [1 ..]))\n (putStrLn . displayContextException))\n (putStrLn . displayParseException)\n\n-- | Run the substitution model on the code.\nrunStepperIO ::\n forall m. (MonadSupply Int m, MonadThrow m, MonadIO m)\n => Run\n -> Maybe Integer\n -> Context Type Name Location\n -> [BindGroup Type Name Location]\n -> String\n -> m ()\nrunStepperIO Run {..} maxSteps ctx bindGroups' i = do\n e0 <- lookupNameByString i bindGroups'\n loop 1 \"\" e0\n where\n loop :: Integer -> String -> Expression Type Name Location -> m ()\n loop count lastString e = do\n e' <- expandSeq1 ctx bindGroups' e\n let string = printExpression (defaultPrint) e\n when\n (string /= lastString && not runHideSteps)\n (if cleanExpression e || not runConcise\n then liftIO\n (putStrLn\n ((if runNumbered\n then \"[\" ++ show count ++ \"]\\n\"\n else \"\") ++\n printExpression defaultPrint e))\n else pure ())\n e'' <- pickUpIO e'\n if (fmap (const ()) e'' /= fmap (const ()) e) &&\n case maxSteps of\n Just top -> count < top\n Nothing -> True\n then do\n newE <-\n renameExpression\n (contextSpecials ctx)\n (contextScope ctx)\n (contextDataTypes ctx)\n e''\n loop (count + 1) string newE\n else pure ()\n\npickUpIO :: MonadIO m => Expression t Name l -> m (Expression t Name l)\npickUpIO =\n \\case\n ApplicationExpression _ (ApplicationExpression _ (ConstructorExpression _ (ConstructorName _ \"PutStrLn\")) (LiteralExpression _ (StringLiteral toBePrinted))) next -> do\n liftIO (putStrLn toBePrinted)\n pure next\n ApplicationExpression l (ConstructorExpression _ (ConstructorName _ \"GetLine\")) func -> do\n inputString <- liftIO getLine\n pure (ApplicationExpression l func (LiteralExpression l (StringLiteral inputString)))\n e -> pure e\n\n-- | Filter out expressions with intermediate case, if and immediately-applied lambdas.\ncleanExpression :: Expression Type i l -> Bool\ncleanExpression =\n \\case\n CaseExpression {} -> False\n IfExpression {} -> False\n e0\n | (LambdaExpression {}, args) <- fargs e0 -> null args\n ApplicationExpression _ f x -> cleanExpression f && cleanExpression x\n _ -> True\n"
},
{
"path": "duet.cabal",
"content": "name:\n duet\nversion:\n 0.0.2\ncabal-version:\n >=1.10\nbuild-type:\n Simple\nmaintainer:\n chrisdone@gmail.com\nsynopsis:\n A tiny language, a subset of Haskell (with type classes) aimed at aiding teachers to teach Haskell\ndescription:\n A tiny language, a subset of Haskell (with type classes) aimed at aiding teachers to teach Haskell\nlicense: BSD3\nextra-source-files: README.md, LICENSE.md\n\nlibrary\n hs-source-dirs:\n src\n build-depends:\n base >= 4.5 && < 5,\n containers,\n mtl,\n exceptions,\n parsec,\n text,\n edit-distance,\n deepseq,\n aeson,\n syb,\n monad-logger\n ghc-options:\n -Wall\n default-language:\n Haskell2010\n exposed-modules:\n Duet.Infer\n Duet.Types\n Duet.Parser\n Duet.Printer\n Duet.Tokenizer\n Duet.Renamer\n Duet.Resolver\n Duet.Stepper\n Duet.Errors\n Duet.Supply\n Duet.Context\n Duet.Setup\n Duet.Simple\n Control.Monad.Supply\n\ntest-suite duet-test\n type: exitcode-stdio-1.0\n main-is: Spec.hs\n hs-source-dirs: test\n ghc-options: -Wall -O0\n default-language: Haskell2010\n build-depends:\n base >= 4.5 && < 5, duet,\n containers,\n mtl,\n exceptions,\n parsec,\n text,\n edit-distance,\n deepseq,\n aeson,\n syb,\n hspec,\n monad-logger\n\nexecutable duet\n main-is: Main.hs\n hs-source-dirs: app\n ghc-options: -Wall\n default-language: Haskell2010\n build-depends:\n base >= 4.5 && < 5, duet,\n containers,\n mtl,\n exceptions,\n text,\n deepseq,\n aeson,\n syb,\n monad-logger,\n optparse-simple\n"
},
{
"path": "examples/ack.hs",
"content": "data Tuple a b = Tuple a b\n\nack = \\m n ->\n case Tuple m n of\n Tuple 0 n -> n + 1\n Tuple m 0 -> ack (m - 1) 1\n Tuple m n -> ack (m - 1) (ack m (n - 1))\n\nmain = ack 4 0\n"
},
{
"path": "examples/arith.hs",
"content": "main = 22.0 + 33.0\n"
},
{
"path": "examples/bound.hs",
"content": "class Bounded a where\n minBound :: a\n maxBound :: a\ninstance Bounded Bool where\n minBound = False\n maxBound = True\ndata Tuple a a = Tuple a a\nmain = Tuple True minBound\n"
},
{
"path": "examples/builtins.hs",
"content": "data X = X Integer Char Rational String\nclass Show a where show :: a -> String\ninstance Show Integer where show = \\_ -> \"a\"\nfoo :: X -> Integer\nfoo = \\x -> 123\n"
},
{
"path": "examples/classes.hs",
"content": "class Reader a where\n reader :: List Ch -> a\nclass Shower a where\n shower :: a -> List Ch\ninstance Shower Nat where\n shower = \\n ->\n case n of\n Zero -> Cons Z Nil\n Succ n -> Cons S (shower n)\ndata Nat = Succ Nat | Zero\ninstance Reader Nat where\n reader = \\cs ->\n case cs of\n Cons Z Nil -> Zero\n Cons S xs -> Succ (reader xs)\n _ -> Zero\ndata List a = Nil | Cons a (List a)\ndata Ch = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z\nclass Equal a where\n equal :: a -> a -> Bool\ninstance Equal Nat where\n equal =\n \\a b ->\n case a of\n Zero ->\n case b of\n Zero -> True\n _ -> False\n Succ n ->\n case b of\n Succ m -> equal n m\n _ -> False\n _ -> False\nnot = \\b -> case b of\n True -> False\n False -> True\n\nnotEqual :: Equal a => a -> a -> Bool\nnotEqual = \\x y -> not (equal x y)\n\nmain = equal (reader (shower (Succ Zero))) (Succ Zero)\n"
},
{
"path": "examples/fac.hs",
"content": "factorial = \\n -> case n of\n 0 -> 1\n 1 -> 1\n _ -> n * factorial (n - 1)\n\n\ngo =\n \\n acc0 ->\n case acc0 of\n acc ->\n case n of\n 0 -> acc\n 1 -> acc\n _ -> go (n - 1) (n * acc)\n\ngo_efficient =\n \\n acc0 ->\n case acc0 of\n !acc ->\n case n of\n 0 -> acc\n 1 -> acc\n nf -> go_efficient (nf - 1) (nf * acc)\n\nit = go 5 1\n\nit_efficient = go_efficient 5 1\n"
},
{
"path": "examples/factorial.hs",
"content": "data N = S N | Z | M N N\nsub = \\n -> case n of\n S c -> c\nfac = \\n -> case n of\n Z -> S Z\n _ -> M n (fac (sub n))\n\nfacAcc = \\a n ->\n case n of\n Z -> a\n _ -> facAcc (M n a) (sub n)\n\nfacA = facAcc (S Z)\nid = \\x -> x\nmain = fac (S (S Z))\n"
},
{
"path": "examples/folds-strictness.hs",
"content": "data List a = Nil | Cons a (List a)\nfoldr = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> f x (foldr f z xs)\nfoldl = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> foldl f (f z x) xs\nfoldl_ = \\f z l ->\n case l of\n Nil -> z\n Cons x xs ->\n case f z x of\n !z_ -> foldl_ f z_ xs\nlist = (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))\nmain_foldr = foldr _f _nil list\nmain_foldl = foldl _f _nil list\nmain_foldl_ = foldl_ (\\x y -> x + y) 0 list\n"
},
{
"path": "examples/folds.hs",
"content": "data List a = Nil | Cons a (List a)\nfoldr = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> f x (foldr f z xs)\nfoldl = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> foldl f (f z x) xs\nlist = (Cons True (Cons False Nil))\n\nmain_foldr = foldr _f _nil list\nmain_foldl = foldl _f _nil list\n"
},
{
"path": "examples/functor-class.hs",
"content": "data Maybe a = Nothing | Just a\nclass Functor (f :: Type -> Type) where\n map :: (a -> b) -> f a -> f b\ninstance Functor Maybe where\n map = \\f m ->\n case m of\n Nothing -> Nothing\n Just a -> Just (f a)\nnot = \\b -> case b of\n True -> False\n False -> True\nmain = map (\\x -> x) (Just 123)\n"
},
{
"path": "examples/gabriel-eq-reason.hs",
"content": "data IO a = Print Nat (IO a) | Return a\n\ndata Nat = Z | S Nat\n\ndata List a = Nil | Cons a (List a)\n\ndata Unit = Unit\n\nbind =\n \\m f ->\n case m of\n Return a -> f a\n Print bool m1 -> Print bool (bind m1 f)\n\nnext = \\m n ->\n bind m (\\_ -> n)\n\nprint = \\x -> Print x (Return Unit)\n\nreturn = Return\n\nrepeat = \\x -> Cons x (repeat x)\n\nfoldr = \\cons nil l ->\n case l of\n Nil -> nil\n Cons x xs -> cons x (foldr cons nil xs)\n\nsequence_ = \\ms -> foldr next (return Unit) ms\n\ntake =\n \\n l ->\n case n of\n Z -> Nil\n S m ->\n case l of\n Nil -> Nil\n Cons x xs -> Cons x (take m xs)\n\nreplicate = \\n x -> take n (repeat x)\n\nreplicateM_ = \\n m -> sequence_ (replicate n m)\n\nmain = replicateM_ (S (S (S (S (S (S Z)))))) (print (S Z))\n"
},
{
"path": "examples/good.hs",
"content": "class Good a where\n good :: a -> Bool\ndata Maybe a = Just a | Nothing\ninstance Good Bool where\n good = \\x -> x\ninstance Good a => Good (Maybe a) where\n good = \\x ->\n case x of\n Nothing -> False\n Just a -> good a\nmain = good (Just True)\n"
},
{
"path": "examples/integers.hs",
"content": "main = 3 + ((2 + -3) - 3)\n"
},
{
"path": "examples/lists.hs",
"content": "data List a = Nil | Cons a (List a)\nmap = \\f xs ->\n case xs of\n Nil -> Nil\n Cons x xs -> Cons (f x) (map f xs)\nlist = (Cons 1 (Cons 2 Nil))\nmultiply = \\x y -> x * y\ndoubleAll = \\xs -> map (multiply 2) xs\nmain = doubleAll list\n"
},
{
"path": "examples/monad.hs",
"content": "class Monad (m :: Type -> Type) where\n bind :: m a -> (a -> m b) -> m b\nclass Applicative (f :: Type -> Type) where\n pure :: a -> f a\n ap :: f (a -> b) -> f a -> f b\nclass Functor (f :: Type -> Type) where\n map :: (a -> b) -> f a -> f b\ndata Maybe a = Nothing | Just a\ninstance Functor Maybe where\n map =\n \\f m ->\n case m of\n Nothing -> Nothing\n Just a -> Just (f a)\ninstance Monad Maybe where\n bind =\n \\m f ->\n case m of\n Nothing -> Nothing\n Just v -> f v\ninstance Applicative Maybe where\n pure = \\v -> Just v\n ap = \\a b -> Nothing\n"
},
{
"path": "examples/monoid.hs",
"content": "class Monoid a where\n mempty :: a\n mappend :: a -> a -> a\ndata List a = Nil | Cons a (List a)\ninstance Monoid (List a) where\n mempty = Nil\n mappend = \\x y ->\n case x of\n Cons a xs -> Cons a (mappend xs y)\n Nil -> y\nmain = mappend (Cons 'a' (Cons 'b' Nil)) (Cons 'c' (Cons 'd' Nil))\n"
},
{
"path": "examples/ord.hs",
"content": "class Ord a where\n compare :: a -> a -> Ordering\ndata Ordering\n = EQ\n | LT\n | GT\ninstance Ord Ordering where\n compare =\n \\x y ->\n case x of\n LT ->\n case y of\n LT -> EQ\n EQ -> LT\n GT -> LT\n EQ ->\n case y of\n LT -> GT\n EQ -> EQ\n GT -> LT\n GT ->\n case y of\n LT -> GT\n EQ -> GT\n GT -> EQ\nmain = compare EQ LT\n"
},
{
"path": "examples/parser.hs",
"content": "data Tuple a b = Tuple a b\ndata Result a = OK a String | Error String\ndata Parser a = Parser (String -> Result a)\nparseBool =\n Parser\n (\\string ->\n case take 4 string of\n \"True\" ->\n case drop 4 string of\n !rest -> OK True rest\n _ ->\n case take 5 string of\n \"False\" ->\n case drop 5 string of\n !rest -> OK False rest\n _ -> Error (append \"Expected a bool, but got: \" string))\nrunParser =\n \\p s ->\n case p of\n Parser f -> f s\nbind =\n \\m f ->\n Parser\n (\\s ->\n case runParser m s of\n OK a rest -> runParser (f a) rest\n Error err -> Error err)\npure = \\a -> Parser (OK a)\nmain = runParser (bind parseBool (\\x -> bind parseBool (\\y -> pure (Tuple x y)))) \"TrueFalse\"\n"
},
{
"path": "examples/pattern-matching.hs",
"content": "data Uk = Manchester | Bristol\n\ndata Italy = Trento | Padova\n\ndata Europe = Uk Uk | Italy Italy\n\nbristol = Bristol\n\nmain = case Uk bristol of\n Uk Manchester -> \"uk-manc\"\n Uk Bristol -> \"uk-bristol\"\n Italy Trento -> \"italy-trento\"\n Italy Padova -> \"italy-padova\"\n"
},
{
"path": "examples/placeholders.hs",
"content": "data List a = Nil | Cons a (List a)\nfoldr = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> f x (foldr f z xs)\nfoldl = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> foldl f (f z x) xs\nlist = (Cons True (Cons False Nil))\nmain = foldr _f _nil list\n"
},
{
"path": "examples/prelude.hs",
"content": "data Bool = True | False\n\ndata Ordering = EQ | LT | GT\n\nclass Eq a where\n equal :: a -> a -> Bool\n notEqual :: a -> a -> Bool\n\nclass Ord a where\n compare :: a -> a -> Ordering\n\nclass Monad (m :: Type -> Type) where\n bind :: m a -> (a -> m b) -> m b\n\nclass Applicative (f :: Type -> Type) where\n pure :: a -> f a\n ap :: f (a -> b) -> f a -> f b\n\nclass Functor (f :: Type -> Type) where\n map :: (a -> b) -> f a -> f b\n\nclass Num a where\n plus :: a -> a -> a\n times :: a -> a -> a\n\nclass Neg a where\n negate :: a -> a\n abs :: a -> a\n subtract :: a -> a -> a\n\nclass MinBound b where\n minBound :: b\n\nclass MaxBound b where\n maxBound :: b\n\nclass Integral a where\n div :: a -> a -> a\n mod :: a -> a -> a\n\nclass Fractional a where\n divide :: a -> a -> a\n recip :: a -> a\n"
},
{
"path": "examples/seq.hs",
"content": "seq :: a -> b -> b\nseq =\n \\x y ->\n case x of\n !_ -> y\nloop = loop\nmain = seq loop 1\n"
},
{
"path": "examples/sicp.hs",
"content": "square = \\x -> x * x\nit = square 6 + square 10\n"
},
{
"path": "examples/simple-class.hs",
"content": "class X a where\n f :: a -> D\ndata D = D | C\ninstance X D where\n f = \\x -> case x of\n D -> D\n C -> f D\n\nmain = f C\n"
},
{
"path": "examples/state.hs",
"content": "data Unit = Unit\nclass Monad (m :: Type -> Type) where\n bind :: m a -> (a -> m b) -> m b\nclass Applicative (f :: Type -> Type) where\n pure :: a -> f a\nclass Functor (f :: Type -> Type) where\n map :: (a -> b) -> f a -> f b\ndata Result s a = Result s a\ndata State s a = State (s -> Result s a)\ninstance Functor (State s) where\n map =\n \\f state ->\n case state of\n State s2r ->\n State\n (\\s ->\n case s2r s of\n Result s1 a -> Result s1 (f a))\ninstance Monad (State s) where\n bind =\n \\m f ->\n case m of\n State s2r ->\n State\n (\\s ->\n case s2r s of\n Result s a ->\n case f a of\n State s2r1 -> s2r1 s)\ninstance Applicative (State s) where\n pure = \\a -> State (\\s -> Result s a)\nrunState =\n \\m a ->\n case m of\n State f -> f a\nget = State (\\s -> Result s s)\nput = \\s -> State (\\k -> Result s Unit)\nnext = \\m n -> bind m (\\_ -> n)\nmain = runState (next (put False) (pure Unit)) True\n"
},
{
"path": "examples/strict-folds.hs",
"content": "data List a = Nil | Cons a (List a)\nfoldr = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> f x (foldr f z xs)\nfoldl = \\f z l ->\n case l of\n Nil -> z\n Cons x xs -> foldl f (f z x) xs\nlist = (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))\nmain_foldr = foldr (+) _nil list\nmain_foldl = foldl (+) _nil list\n"
},
{
"path": "examples/string-pats.hs",
"content": "main =\n case \"foo\" of\n \"bar\" -> 0\n \"foo\" -> 1\n"
},
{
"path": "examples/string-substring.hs",
"content": "main = append (take 2 (drop 7 \"Hello, World!\")) \"!\"\n"
},
{
"path": "examples/syntax-buffet.hs",
"content": "class Reader a where\n reader :: List Ch -> a\nclass Shower a where\n shower :: a -> List Ch\ninstance Shower Nat where\n shower = \\n ->\n case n of\n Zero -> Cons Z Nil\n Succ n -> Cons S (shower n)\ndata Nat = Succ Nat | Zero\ninstance Reader Nat where\n reader = \\cs ->\n case cs of\n Cons Z Nil -> Zero\n Cons S xs -> Succ (reader xs)\n _ -> Zero\ndata List a = Nil | Cons a (List a)\ndata Ch = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z\nclass Equal a where\n equal :: a -> a -> Bool\ninstance Equal Nat where\n equal =\n \\a b ->\n case a of\n Zero ->\n case b of\n Zero -> True\n _ -> False\n Succ n ->\n case b of\n Succ m -> equal n m\n _ -> False\n _ -> False\nnot = \\b -> case b of\n True -> False\n False -> True\nnotEqual :: Equal a => a -> a -> Bool\nnotEqual = \\x y -> not (equal x y)\nmain = if not False\n then equal (reader (shower (Succ Zero))) (Succ Zero)\n else False\n"
},
{
"path": "examples/terminal.hs",
"content": "data Terminal a\n = GetLine (String -> Terminal a)\n | PutStrLn String (Terminal a)\n | Pure a\n\nmain =\n PutStrLn\n \"Please enter your name: \"\n (GetLine (\\line -> PutStrLn (append \"Hello, \" line) (Pure 0)))\n"
},
{
"path": "src/Control/Monad/Supply.hs",
"content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE FunctionalDependencies #-}\n{-# LANGUAGE UndecidableInstances #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n{-# LANGUAGE MultiParamTypeClasses #-}\n\n-- | Support for computations which consume values from a (possibly infinite)\n-- supply. See for\n-- details.\n--\n-- Patched to provide MonadCatch/MonadThrow instead of MonadError.\n--\nmodule Control.Monad.Supply\n( MonadSupply (..)\n, SupplyT\n, Supply\n, evalSupplyT\n, evalSupply\n, runSupplyT\n, runSupply\n) where\n\nimport Control.Monad.Catch\nimport Control.Monad.Identity\n#ifndef __GHCJS__\nimport Control.Monad.Logger\n#endif\nimport Control.Monad.Reader\nimport Control.Monad.State\nimport Control.Monad.Writer\n\nclass Monad m => MonadSupply s m | m -> s where\n supply :: m s\n peek :: m s\n exhausted :: m Bool\n\n-- | Supply monad transformer.\nnewtype SupplyT s m a = SupplyT (StateT [s] m a)\n#ifdef __GHCJS__\n deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFix, MonadCatch, MonadThrow)\n#else\n deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFix, MonadCatch, MonadThrow, MonadLogger)\n#endif\n-- | Supply monad.\nnewtype Supply s a = Supply (SupplyT s Identity a)\n deriving (Functor, Applicative, Monad, MonadSupply s, MonadFix)\n\ninstance Monad m => MonadSupply s (SupplyT s m) where\n supply =\n SupplyT $ do\n result <- get\n case result of\n (x:xs) -> do\n put xs\n return x\n _ -> error \"Exhausted supply in Control.Monad.Supply.hs\"\n peek = SupplyT $ gets head\n exhausted = SupplyT $ gets null\n\ninstance MonadSupply s m => MonadSupply s (StateT st m) where\n supply = lift supply\n peek = lift peek\n exhausted = lift exhausted\n\ninstance MonadSupply s m => MonadSupply s (ReaderT r m) where\n supply = lift supply\n peek = lift peek\n exhausted = lift exhausted\n\ninstance (Monoid w, MonadSupply s m) => MonadSupply s (WriterT w m) where\n supply = lift supply\n peek = lift peek\n exhausted = lift exhausted\n\nevalSupplyT :: Monad m => SupplyT s m a -> [s] -> m a\nevalSupplyT (SupplyT s) = evalStateT s\n\nevalSupply :: Supply s a -> [s] -> a\nevalSupply (Supply s) = runIdentity . evalSupplyT s\n\nrunSupplyT :: Monad m => SupplyT s m a -> [s] -> m (a,[s])\nrunSupplyT (SupplyT s) = runStateT s\n\nrunSupply :: Supply s a -> [s] -> (a,[s])\nrunSupply (Supply s) = runIdentity . runSupplyT s\n"
},
{
"path": "src/Duet/Context.hs",
"content": "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE FlexibleContexts #-}\n\n-- | Functions for setting up the context.\n\nmodule Duet.Context where\n\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Duet.Infer\nimport Duet.Renamer\nimport Duet.Supply\nimport Duet.Types\n\n-- | Make an instance.\nmakeInst\n :: MonadSupply Int m\n => Specials Name\n -> Predicate Type Name\n -> [(String, (l, Alternative Type Name l))]\n -> m (Instance Type Name l)\nmakeInst specials pred' methods = do\n name <- supplyDictName (predicateToDict specials pred')\n methods' <-\n mapM\n (\\(key, alt) -> do\n key' <- supplyMethodName (Identifier key)\n pure (key', alt))\n methods\n pure (Instance (Forall [] (Qualified [] pred')) (Dictionary name (M.fromList methods')))\n\n-- | Make a class.\nmakeClass\n :: MonadSupply Int m\n => Identifier\n -> [TypeVariable Name]\n -> [(Name, Scheme t Name t)]\n -> m (Class t Name l)\nmakeClass name vars methods = do\n name' <- supplyClassName name\n pure\n (Class\n { className = name'\n , classTypeVariables = vars\n , classInstances = []\n , classMethods = M.fromList methods\n , classSuperclasses = mempty\n })\n\n-- | Generate signatures from a data type.\ndataTypeSignatures\n :: Monad m\n => SpecialTypes Name -> DataType Type Name -> m [TypeSignature Type Name Name]\ndataTypeSignatures specialTypes dt@(DataType _ vs cs) = mapM construct cs\n where\n construct (DataTypeConstructor cname fs) =\n pure\n (TypeSignature\n cname\n (Forall\n vs\n (Qualified\n []\n (foldr\n makeArrow\n (foldl\n ApplicationType\n (dataTypeConstructor dt)\n (map VariableType vs))\n fs))))\n where\n makeArrow :: Type Name -> Type Name -> Type Name\n a `makeArrow` b =\n ApplicationType\n (ApplicationType\n (ConstructorType (specialTypesFunction specialTypes))\n a)\n b\n\n-- | Make signatures from a class.\nclassSignatures\n :: MonadThrow m\n => Class Type Name l -> m [TypeSignature Type Name Name]\nclassSignatures cls =\n mapM\n (\\(name, scheme) ->\n TypeSignature <$> pure name <*> classMethodScheme cls scheme)\n (M.toList (classMethods cls))\n\nbuiltinsSpecials :: Builtins t i l -> Specials i\nbuiltinsSpecials builtins =\n Specials (builtinsSpecialSigs builtins) (builtinsSpecialTypes builtins)\n\ncontextSpecials :: Context t i l -> Specials i\ncontextSpecials context =\n Specials (contextSpecialSigs context) (contextSpecialTypes context)\n\ngenerateAllSignatures :: (MonadThrow m, Traversable t, Traversable t1) => Builtins Type Name l1 -> t1 (DataType Type Name) -> t (Class Type Name l) -> m [TypeSignature Type Name Name]\ngenerateAllSignatures builtins dataTypes typeClasses =\n do consSigs <-\n fmap\n concat\n (mapM (dataTypeSignatures (builtinsSpecialTypes builtins)) dataTypes)\n methodSigs <- fmap concat (mapM classSignatures typeClasses)\n pure (builtinsSignatures builtins <> consSigs <> methodSigs)\n\nmakeScope :: Applicative f => M.Map Identifier (Class t2 Name l) -> [TypeSignature t1 t Name] -> f (M.Map Identifier Name)\nmakeScope typeClasses signatures =\n pure\n (M.fromList\n (mapMaybe\n (\\(TypeSignature name _) ->\n case name of\n ValueName _ ident -> Just (Identifier ident, name)\n ConstructorName _ ident -> pure (Identifier ident, name)\n MethodName _ ident -> pure (Identifier ident, name)\n _ -> Nothing)\n signatures) <>\n M.map className typeClasses)\n\nrenameEverything ::\n (MonadThrow m, MonadSupply Int m)\n => [Decl UnkindedType Identifier Location]\n -> Specials Name\n -> Builtins Type Name Location\n -> m ( M.Map Identifier (Class Type Name Location)\n , [TypeSignature Type Name Name]\n , [Binding Type Name Location]\n , M.Map Identifier Name\n , [DataType Type Name])\nrenameEverything decls specials builtins = do\n dataTypes <- renameDataTypes specials (declsDataTypes decls)\n (typeClasses, signatures, subs) <-\n do typeClasses <-\n fmap\n M.fromList\n (mapM\n (\\c -> do\n renamed <- renameClass specials mempty dataTypes c\n pure (className c, renamed))\n classes)\n signatures <- generateAllSignatures builtins dataTypes typeClasses\n scope <- makeScope typeClasses signatures\n allInstances <-\n mapM\n (renameInstance specials scope dataTypes (M.elems typeClasses))\n instances\n pure\n ( M.map\n (\\typeClass ->\n typeClass\n { classInstances =\n filter\n ((== className typeClass) . instanceClassName)\n allInstances\n })\n typeClasses\n , signatures\n , scope)\n (renamedBindings, subs') <- renameBindings specials subs dataTypes bindings\n pure (typeClasses, signatures, renamedBindings, subs', dataTypes)\n where declsDataTypes =\n mapMaybe\n (\\case\n DataDecl _ d -> Just d\n _ -> Nothing)\n bindings =\n mapMaybe\n (\\case\n BindDecl _ d -> Just d\n _ -> Nothing)\n decls\n classes =\n mapMaybe\n (\\case\n ClassDecl _ d -> Just d\n _ -> Nothing)\n decls\n instances =\n mapMaybe\n (\\case\n InstanceDecl _ d -> Just d\n _ -> Nothing)\n decls\n\naddClasses :: (MonadThrow m, Foldable t) => Builtins Type Name l -> t (Class Type Name l) -> m (M.Map Name (Class Type Name l))\naddClasses builtins typeClasses =\n foldM\n (\\e0 typeClass ->\n addClass typeClass e0 >>= \\e ->\n foldM (\\e1 i -> do addInstance i e1) e (classInstances typeClass))\n (builtinsTypeClasses builtins)\n typeClasses\n"
},
{
"path": "src/Duet/Errors.hs",
"content": "{-# LANGUAGE LambdaCase #-}\n\n-- |\n\nmodule Duet.Errors where\n\nimport Control.Exception\nimport Data.Char\nimport Data.Function\nimport Data.List\nimport qualified Data.Map.Strict as M\nimport Data.Ord\nimport Data.Typeable\nimport Duet.Printer\nimport Duet.Types\nimport Text.EditDistance\n\ndisplayContextException :: ContextException -> String\ndisplayContextException (ContextException specialTypes (SomeException se)) =\n maybe\n (maybe\n (maybe\n (maybe\n (maybe\n (displayException se)\n (displayRenamerException specialTypes)\n (cast se))\n (displayInferException specialTypes)\n (cast se))\n (displayStepperException specialTypes)\n (cast se))\n (displayResolveException specialTypes)\n (cast se))\n displayParseException\n (cast se)\n\ndisplayParseException :: ParseException -> String\ndisplayParseException e =\n case e of\n TokenizerError pe -> show pe\n ParserError pe -> show pe\n\ndisplayResolveException :: SpecialTypes Name -> ResolveException -> String\ndisplayResolveException specialTypes =\n \\case\n NoInstanceFor p -> \"No instance for \" ++ printPredicate defaultPrint specialTypes p\n\ndisplayStepperException :: a -> StepException -> String\ndisplayStepperException _ =\n \\case\n CouldntFindName n ->\n \"Not in scope: \" ++ curlyQuotes (printit defaultPrint n)\n CouldntFindMethodDict n ->\n \"No instance dictionary for: \" ++ curlyQuotes (printit defaultPrint n)\n CouldntFindNameByString n ->\n \"The starter variable isn't defined: \" ++\n curlyQuotes n ++ \"\\nPlease define a variable called \" ++ curlyQuotes n\n TypeAtValueScope k -> \"Type at value scope: \" ++ show k\n\ndisplayInferException :: SpecialTypes Name -> InferException -> [Char]\ndisplayInferException specialTypes =\n \\case\n ExplicitTypeMismatch sc1 sc2 ->\n \"The type of a definition, \\n\\n \" ++\n printScheme defaultPrint specialTypes sc2 ++ \"\\n\\ndoesn't match the explicit type:\\n\\n \" ++\n printScheme defaultPrint specialTypes sc1\n NotInScope scope name ->\n \"Not in scope \" ++\n curlyQuotes (printit defaultPrint name) ++\n \"\\n\" ++\n \"Nearest names in scope:\\n\\n\" ++\n intercalate\n \", \"\n (map\n curlyQuotes\n (take\n 5\n (sortBy\n (comparing (editDistance (printit defaultPrint name)))\n (map (printTypeSignature defaultPrint specialTypes) scope))))\n TypeMismatch t1 t2 ->\n \"Couldn't match type \" ++\n curlyQuotes (printType defaultPrint specialTypes t1) ++\n \"\\n\" ++\n \"against inferred type \" ++ curlyQuotes (printType defaultPrint specialTypes t2)\n OccursCheckFails ->\n \"Infinite type (occurs check failed). \\nYou \\\n \\probably have a self-referential value!\"\n AmbiguousInstance ambiguities ->\n \"Couldn't infer which instances to use for\\n\" ++\n unlines\n (map\n (\\(Ambiguity _ ps) ->\n intercalate \", \" (map (printPredicate defaultPrint specialTypes) ps))\n ambiguities)\n e -> show e\n\ndisplayRenamerException :: SpecialTypes Name -> RenamerException -> [Char]\ndisplayRenamerException specialTypes =\n wrap (\\case\n IdentifierNotInVarScope scope name label ->\n \"Not in variable scope \" ++\n curlyQuotes (printit defaultPrint name) ++\n -- \" (AST tree label: \"++show label ++\")\"++\n \"\\n\" ++\n \"Nearest names in scope:\\n\\n\" ++\n intercalate\n \", \"\n (map\n curlyQuotes\n (take\n 5\n (sortBy\n (comparing (editDistance (printit defaultPrint name)))\n (map (printit defaultPrint) (M.elems scope)))))\n IdentifierNotInConScope scope name ->\n \"Not in constructors scope \" ++\n curlyQuotes (printit defaultPrint name) ++\n \"\\n\" ++\n \"Nearest names in scope:\\n\\n\" ++\n intercalate\n \", \"\n (map\n curlyQuotes\n (take\n 5\n (sortBy\n (comparing (editDistance (printit defaultPrint name)))\n (map (printit defaultPrint) (M.elems scope)))))\n KindTooManyArgs ty k ty2 ->\n \"The type \" ++\n curlyQuotes (printType defaultPrint specialTypes ty ++ \" :: \" ++ printKind k) ++\n \" has an unexpected additional argument, \" ++\n curlyQuotes (printType defaultPrint specialTypes ty2)\n ConstructorFieldKind cons typ kind ->\n \"The type \" ++\n curlyQuotes (printType defaultPrint specialTypes typ ++ \" :: \" ++ printKind kind) ++\n \" is used in a field in the \" ++\n curlyQuotes (printit defaultPrint cons) ++\n \" constructor, but all fields \\\n \\should have types of kind \" ++\n curlyQuotes (printKind StarKind)\n KindArgMismatch t1 k1 t2 k2 ->\n \"The type \" ++\n curlyQuotes (printType defaultPrint specialTypes t1 ++ \" :: \" ++ printKind k1) ++\n \" has been given an argument of the wrong kind \" ++\n curlyQuotes (printType defaultPrint specialTypes t2 ++ \" :: \" ++ printKind k2)\n TypeNotInScope types i ->\n \"Unknown type \" ++\n curlyQuotes (printIdentifier defaultPrint i) ++\n \"\\n\" ++\n \"Closest names in scope are: \" ++\n intercalate\n \", \"\n (map\n curlyQuotes\n (take\n 5\n (sortBy\n (comparing (editDistance (printIdentifier defaultPrint i)))\n (map (printTypeConstructor defaultPrint) types))))\n UnknownTypeVariable types i ->\n \"Unknown type variable \" ++\n curlyQuotes (printIdentifier defaultPrint i) ++\n \"\\n\" ++\n \"Type variables in scope are: \" ++\n intercalate\n \", \"\n (map\n curlyQuotes\n (sortBy\n (comparing (editDistance (printIdentifier defaultPrint i)))\n (map (printTypeVariable defaultPrint) types)))\n e -> show e)\n where wrap f e = (f e)-- ++ \"\\n(\" ++ show e ++ \")\"\n\neditDistance :: [Char] -> [Char] -> Int\neditDistance = on (levenshteinDistance defaultEditCosts) (map toLower)\n"
},
{
"path": "src/Duet/Infer.hs",
"content": "{-# LANGUAGE KindSignatures #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE DeriveTraversable #-}\n{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n\n-- | A clear-to-read, well-documented, implementation of a Haskell 98\n-- type checker adapted from Typing Haskell In Haskell, by Mark\n-- P. Jones.\n\nmodule Duet.Infer\n (\n -- * Type checker\n -- $type-checker\n typeCheckModule\n , byInst\n , InferException(..)\n -- * Setting up\n , addClass\n , addInstance\n , SpecialTypes(..)\n , ReadException(..)\n -- * Printers\n -- , printTypeSignature\n -- * Types syntax tree\n , Type(..)\n , Kind(..)\n , Scheme(..)\n , TypeSignature(..)\n , TypeVariable(..)\n , Qualified(..)\n , Class(..)\n , Predicate(..)\n , TypeConstructor(..)\n -- * Values syntax tree\n , ImplicitlyTypedBinding(..)\n , ExplicitlyTypedBinding(..)\n , Expression(..)\n , Literal(..)\n , Pattern(..)\n , BindGroup(..)\n , Alternative(..)\n , toScheme\n , typeKind\n , classMethodScheme\n ) where\n\nimport Control.Arrow (first,second)\nimport Control.Monad.Catch\nimport Control.Monad.State\nimport Data.Generics\nimport Data.Graph\nimport Data.List\nimport Data.Map.Strict (Map)\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Duet.Types\n\n--------------------------------------------------------------------------------\n-- Type inference\n--\n\n-- $type-checker\n--\n-- The type checker takes a module and produces a list of type\n-- signatures. It checks that all types unify, and infers the types of\n-- unannotated expressions. It resolves type-class instances.\n\n-- | Type check the given module and produce a list of type\n-- signatures.\n--\n-- >>> fmap (map printTypeSignature) (typeCheckModule mempty [] [BindGroup [] [[ImplicitlyTypedBinding (Identifier \"id\") [Alternative [VariablePattern (Identifier \"x\")] (VariableExpression (Identifier \"x\"))]]]])\n-- [\"id :: forall a0. a0 -> a0\"]\n--\n-- Throws 'InferException' in case of a type error.\ntypeCheckModule ::\n (MonadThrow m)\n => Map Name (Class Type Name Location) -- ^ Set of defined type-classes.\n -> [(TypeSignature Type Name Name)] -- ^ Pre-defined type signatures e.g. for built-ins or FFI.\n -> SpecialTypes Name -- ^ Special types that Haskell uses for pattern matching and literals.\n -> [Binding Type Name Location] -- ^ Bindings in the module.\n -> m ( [BindGroup Type Name (TypeSignature Type Name Location)]\n , Map Name (Class Type Name (TypeSignature Type Name Location)))\ntypeCheckModule ce as specialTypes bgs0 = do\n (bgs, classes) <- runTypeChecker (dependencyAnalysis bgs0)\n pure (bgs, classes)\n where\n runTypeChecker bgs =\n evalStateT\n (runInferT $ do\n instanceBgs <- classMethodsToGroups specialTypes ce\n (ps, _, bgs') <-\n inferSequenceTypes inferBindGroupTypes ce as (bgs ++ instanceBgs)\n s <- InferT (gets inferStateSubstitutions)\n let rs = reduce ce (map (substitutePredicate s) ps)\n s' <- defaultSubst ce [] rs\n let bgsFinal = map (fmap (substituteTypeSignature (s' @@ s))) bgs'\n ce' <- collectMethods bgsFinal ce\n return (bgsFinal, ce'))\n (InferState nullSubst 0 specialTypes)\n\n-- | Sort the list of bindings by order of no-dependencies first\n-- followed by things that depend on them. Group bindings that are\n-- mutually recursive.\ndependencyAnalysis :: Data l => [Binding Type Name l] -> [BindGroup Type Name l]\ndependencyAnalysis = map toBindGroup . stronglyConnComp . bindingsGraph\n where\n toBindGroup =\n \\case\n AcyclicSCC binding ->\n BindGroup (explicits [binding]) [implicits [binding]]\n CyclicSCC bindings ->\n BindGroup (explicits bindings) [implicits bindings]\n explicits =\n mapMaybe\n (\\case\n ExplicitBinding i -> Just i\n _ -> Nothing)\n implicits =\n mapMaybe\n (\\case\n ImplicitBinding i -> Just i\n _ -> Nothing)\n\n-- | Make a graph of the bindings with their dependencies.\nbindingsGraph :: Data l => [Binding Type Name l] -> [(Binding Type Name l, Name, [Name])]\nbindingsGraph =\n map\n (\\binding ->\n ( binding\n , bindingIdentifier binding\n , listify\n (\\case\n n@ValueName {} -> n /= bindingIdentifier binding\n _ -> False)\n (bindingAlternatives binding)))\n\ncollectMethods ::\n forall l m. MonadThrow m\n => [BindGroup Type Name (TypeSignature Type Name l)]\n -> Map Name (Class Type Name l)\n -> m (Map Name (Class Type Name (TypeSignature Type Name l)))\ncollectMethods binds =\n fmap M.fromList .\n mapM\n (\\(name, cls) -> do\n insts <-\n mapM\n (\\inst -> do\n methods <-\n mapM\n collectMethod\n (M.toList (dictionaryMethods (instanceDictionary inst)))\n pure\n inst\n { instanceDictionary =\n (instanceDictionary inst)\n {dictionaryMethods = M.fromList methods}\n })\n (classInstances cls)\n pure (name, cls {classInstances = insts})) .\n M.toList\n where\n collectMethod ::\n (Name, (l, t))\n -> m ( Name\n , ( TypeSignature Type Name l\n , Alternative Type Name (TypeSignature Type Name l)))\n collectMethod (key, (l, _)) =\n case listToMaybe\n (mapMaybe\n (\\(BindGroup ex _) ->\n listToMaybe\n (mapMaybe\n (\\i ->\n if fst (explicitlyTypedBindingId i) == key\n then listToMaybe\n (explicitlyTypedBindingAlternatives i)\n else Nothing)\n ex))\n binds) of\n Just alt ->\n pure\n ( key\n , ( TypeSignature l (typeSignatureScheme (alternativeLabel alt))\n , alt))\n Nothing -> throwM MissingMethod\n\nclassMethodsToGroups\n :: MonadThrow m\n => SpecialTypes Name -> Map Name (Class Type Name l) -> m [BindGroup Type Name l]\nclassMethodsToGroups specialTypes =\n mapM\n (\\class' ->\n BindGroup <$>\n fmap\n concat\n (mapM\n (\\inst ->\n sequence\n (zipWith\n (\\methodScheme (instMethodName, (l, methodAlt)) ->\n ExplicitlyTypedBinding <$> pure l <*>\n pure (instMethodName, l) <*>\n instanceMethodScheme\n specialTypes\n class'\n methodScheme\n (instancePredicate inst) <*>\n pure [methodAlt])\n (M.elems (classMethods class'))\n (M.toList (dictionaryMethods (instanceDictionary inst)))))\n (classInstances class')) <*>\n pure []) .\n M.elems\n\ninstanceMethodScheme\n :: MonadThrow m\n => SpecialTypes Name\n -> Class Type Name l\n -> Scheme Type Name Type\n -> Scheme Type Name (Predicate Type)\n -> m (Scheme Type Name Type)\ninstanceMethodScheme _specialTypes cls (Forall methodVars0 (Qualified methodPreds methodType0)) _instScheme@(Forall instanceVars0 (Qualified preds (IsIn _ headTypes))) = do\n methodQual <- instantiateQual (Qualified (methodPreds ++ preds) methodType0)\n pure (Forall methodVars methodQual)\n where\n methodVars = filter (not . flip elem (classTypeVariables cls)) (methodVars0 ++ instanceVars0)\n table = zip (classTypeVariables cls) headTypes\n instantiateQual (Qualified ps t) =\n Qualified <$> mapM instantiatePred ps <*> instantiate t\n instantiatePred (IsIn c t) = IsIn c <$> mapM instantiate t\n instantiate =\n \\case\n ty@(VariableType tyVar) ->\n case lookup tyVar table of\n Nothing -> pure ty\n Just typ -> pure typ\n ApplicationType a b ->\n ApplicationType <$> instantiate a <*> instantiate b\n typ -> pure typ\n\nclassMethodScheme\n :: MonadThrow m\n => Class t Name l -> Scheme Type Name Type -> m (Scheme Type Name Type)\nclassMethodScheme cls (Forall methodVars (Qualified methodPreds methodType)) = do\n ty' <- pure methodType\n headVars <- mapM (pure . VariableType) (classTypeVariables cls)\n pure\n (Forall\n methodVars\n (Qualified (methodPreds ++ [IsIn (className cls) headVars]) ty'))\n\n--------------------------------------------------------------------------------\n-- Substitution\n\ninfixr 4 @@\n(@@) :: [Substitution Name] -> [Substitution Name] -> [Substitution Name]\ns1 @@ s2 = [Substitution u (substituteType s1 t) | (Substitution u t) <- s2] ++ s1\n\nnullSubst :: [Substitution Name]\nnullSubst = []\n\nsubstituteQualified :: [Substitution Name] -> Qualified Type Name (Type Name) -> Qualified Type Name (Type Name)\nsubstituteQualified substitutions (Qualified predicates t) =\n Qualified\n (map (substitutePredicate substitutions) predicates)\n (substituteType substitutions t)\n\nsubstituteTypeSignature :: [Substitution Name] -> (TypeSignature Type Name l) -> (TypeSignature Type Name l)\nsubstituteTypeSignature substitutions (TypeSignature l scheme) =\n TypeSignature l (substituteInScheme substitutions scheme)\n where substituteInScheme subs' (Forall kinds qualified) =\n Forall kinds (substituteQualified subs' qualified)\n\nsubstitutePredicate :: [Substitution Name] -> Predicate Type Name -> Predicate Type Name\nsubstitutePredicate substitutions (IsIn identifier types) =\n IsIn identifier (map (substituteType substitutions) types)\n\nsubstituteType :: [Substitution Name] -> Type Name -> Type Name\nsubstituteType substitutions (VariableType typeVariable) =\n case find ((== typeVariable) . substitutionTypeVariable) substitutions of\n Just substitution -> substitutionType substitution\n Nothing -> VariableType typeVariable\nsubstituteType substitutions (ApplicationType type1 type2) =\n ApplicationType\n (substituteType substitutions type1)\n (substituteType substitutions type2)\nsubstituteType _ typ = typ\n\n--------------------------------------------------------------------------------\n-- Type inference\n\nunify :: MonadThrow m => Type Name -> Type Name -> InferT m ()\nunify t1 t2 = do\n s <- InferT (gets inferStateSubstitutions)\n u <- unifyTypes (substituteType s t1) (substituteType s t2)\n InferT\n (modify\n (\\s' -> s' {inferStateSubstitutions = u @@ inferStateSubstitutions s'}))\n\nnewVariableType :: Monad m => Kind -> InferT m (Type Name)\nnewVariableType k =\n InferT\n (do inferState <- get\n put inferState {inferStateCounter = inferStateCounter inferState + 1}\n return\n (VariableType (TypeVariable (enumId (inferStateCounter inferState)) k)))\n\ninferExplicitlyTypedBindingType\n :: (MonadThrow m, Show l )\n => Map Name (Class Type Name l)\n -> [TypeSignature Type Name Name]\n -> (ExplicitlyTypedBinding Type Name l)\n -> InferT m ([Predicate Type Name], ExplicitlyTypedBinding Type Name (TypeSignature Type Name l))\ninferExplicitlyTypedBindingType ce as (ExplicitlyTypedBinding l (identifier, l') sc alts) = do\n (Qualified qs t) <- freshInst sc\n (ps, alts') <- inferAltTypes ce as alts t\n s <- InferT (gets inferStateSubstitutions)\n let qs' = map (substitutePredicate s) qs\n t' = substituteType s t\n fs =\n getTypeVariablesOf\n getTypeSignatureTypeVariables\n (map (substituteTypeSignature s) as)\n gs = getTypeTypeVariables t' \\\\ fs\n sc' = quantify gs (Qualified qs' t')\n ps' = filter (not . entail ce qs') (map (substitutePredicate s) ps)\n (ds, rs) <- split ce fs gs ps'\n if not (sc `schemesEquivalent` sc')\n then throwM (ExplicitTypeMismatch sc sc')\n else if not (null rs)\n then throwM ContextTooWeak\n else return\n ( ds\n , ExplicitlyTypedBinding\n (TypeSignature l sc)\n (identifier, TypeSignature l' sc)\n sc\n alts')\n\n-- | Are two type schemes alpha-equivalent?\nschemesEquivalent :: Scheme Type Name Type -> Scheme Type Name Type -> Bool\nschemesEquivalent (Forall vs1 q1) (Forall vs2 q2) =\n length vs1 == length vs2 &&\n evalState (goQ q1 q2) (mempty,mempty)\n where\n goQ (Qualified ps1 t1) (Qualified ps2 t2) =\n (&&) <$> fmap and (sequence (zipWith goPred ps1 ps2)) <*> goType t1 t2\n goPred (IsIn x ts1) (IsIn y ts2) =\n ((x == y) &&) <$> fmap and (sequence (zipWith goType ts1 ts2))\n goType (VariableType tv1) (VariableType tv2) = do\n i <- bind fst first tv1\n j <- bind snd second tv2\n pure (i == j)\n goType (ConstructorType c1) (ConstructorType c2) = pure (c1 == c2)\n goType (ApplicationType f1 a1) (ApplicationType f2 a2) =\n (&&) <$> goType f1 f2 <*> goType a1 a2\n goType _ _ = pure False\n bind the upon tv = do\n ctx <- gets the\n case M.lookup tv ctx of\n Nothing -> do\n modify (upon (M.insert tv (M.size ctx)))\n pure (M.size ctx)\n Just j -> pure j\n\ninferImplicitlyTypedBindingsTypes\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> [ImplicitlyTypedBinding Type Name l]\n -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], [ImplicitlyTypedBinding Type Name (TypeSignature Type Name l)])\ninferImplicitlyTypedBindingsTypes ce as bs = do\n ts <- mapM (\\_ -> newVariableType StarKind) bs\n let is = map (fst . implicitlyTypedBindingId) bs\n scs = map toScheme ts\n as' = zipWith (\\x y -> TypeSignature x y) is scs ++ as\n pss0 <-\n sequence\n (zipWith\n (\\b t -> inferAltTypes ce as' (implicitlyTypedBindingAlternatives b) t)\n bs\n ts)\n let pss = map fst pss0\n binds' = map snd pss0\n s <- InferT (gets inferStateSubstitutions)\n let ps' = map (substitutePredicate s) (concat pss)\n ts' = map (substituteType s) ts\n fs =\n getTypeVariablesOf\n getTypeSignatureTypeVariables\n (map (substituteTypeSignature s) as)\n vss = map getTypeTypeVariables ts'\n gs = foldr1' union vss \\\\ fs\n (ds, rs) <- split ce fs (foldr1' intersect vss) ps'\n if restrictImplicitlyTypedBindings bs\n then let gs' = gs \\\\ getTypeVariablesOf getPredicateTypeVariables rs\n scs' = map (quantify gs' . (Qualified [])) ts'\n in return\n ( ds ++ rs\n , zipWith (\\x y -> TypeSignature x y) is scs'\n , zipWith\n (\\(ImplicitlyTypedBinding l (tid, l') _, binds'') scheme ->\n ImplicitlyTypedBinding\n (TypeSignature l scheme)\n (tid, TypeSignature l' scheme)\n binds'')\n (zip bs binds')\n scs')\n else let scs' = map (quantify gs . (Qualified rs)) ts'\n in return\n ( ds\n , zipWith (\\x y -> TypeSignature x y) is scs'\n , zipWith\n (\\(ImplicitlyTypedBinding l (tid, l') _, binds'') scheme ->\n ImplicitlyTypedBinding (TypeSignature l scheme) (tid,TypeSignature l' scheme) binds'')\n (zip bs binds')\n scs')\n where\n foldr1' f xs =\n if null xs\n then []\n else foldr1 f xs\n\ninferBindGroupTypes\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> (BindGroup Type Name l)\n -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], BindGroup Type Name (TypeSignature Type Name l))\ninferBindGroupTypes ce as (BindGroup es iss) = do\n let as' = [TypeSignature v sc | ExplicitlyTypedBinding _ (v, _) sc _alts <- es]\n (ps, as'', iss') <-\n inferSequenceTypes0 inferImplicitlyTypedBindingsTypes ce (as' ++ as) iss\n qss <- mapM (inferExplicitlyTypedBindingType ce (as'' ++ as' ++ as)) es\n return (ps ++ concat (map fst qss), as'' ++ as', BindGroup (map snd qss) iss')\n\ninferSequenceTypes0\n :: Monad m\n => (Map Name (Class Type Name l) -> [(TypeSignature Type Name Name)] -> [bg l] -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], [bg (TypeSignature Type Name l)]))\n -> Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> [[bg l]]\n -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], [[bg (TypeSignature Type Name l)]])\ninferSequenceTypes0 _ _ _ [] = return ([], [], [])\ninferSequenceTypes0 ti ce as (bs:bss) = do\n (ps, as', bs') <- ti ce as bs\n (qs, as'', bss') <- inferSequenceTypes0 ti ce (as' ++ as) bss\n return (ps ++ qs, as'' ++ as', bs' : bss')\n\ninferSequenceTypes\n :: Monad m\n => (Map Name (Class Type Name l) -> [(TypeSignature Type Name Name)] -> bg l -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], bg (TypeSignature Type Name l)))\n -> Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> [bg l]\n -> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], [bg (TypeSignature Type Name l)])\ninferSequenceTypes _ _ _ [] = return ([], [], [])\ninferSequenceTypes ti ce as (bs:bss) = do\n (ps, as', bs') <- ti ce as bs\n (qs, as'', bss') <- inferSequenceTypes ti ce (as' ++ as) bss\n return (ps ++ qs, as'' ++ as', bs' : bss')\n\n--------------------------------------------------------------------------------\n-- Instantiation\n\ninstantiateType :: [(TypeVariable Name, Type Name)] -> Type Name -> Type Name\ninstantiateType ts (ApplicationType l r) =\n ApplicationType (instantiateType ts l) (instantiateType ts r)\ninstantiateType ts ty@(VariableType tyvar) =\n case lookup tyvar ts of\n Nothing -> ty\n Just ty' -> ty' -- TODO: possibly throw error here?\n-- instantiateType ts (GenericType n) = ts !! n\ninstantiateType _ t = t\n\ninstantiateQualified :: [(TypeVariable Name, Type Name)] -> Qualified Type Name (Type Name) -> Qualified Type Name (Type Name)\ninstantiateQualified ts (Qualified ps t) =\n Qualified (map (instantiatePredicate ts) ps) (instantiateType ts t)\n\ninstantiatePredicate :: [(TypeVariable Name, Type Name)] -> Predicate Type Name -> Predicate Type Name\ninstantiatePredicate ts (IsIn c t) = IsIn c (map (instantiateType ts) t)\n\n--------------------------------------------------------------------------------\n-- Type variables\n\ngetTypeSignatureTypeVariables :: (TypeSignature Type Name Name) -> [TypeVariable Name]\ngetTypeSignatureTypeVariables = getTypeVariables where\n getTypeVariables (TypeSignature _ scheme) = getSchemeTypeVariables scheme\n where getSchemeTypeVariables (Forall _ qualified) = getQualifiedTypeVariables qualified\n\ngetQualifiedTypeVariables :: Qualified Type Name (Type Name) -> [TypeVariable Name]\ngetQualifiedTypeVariables = getTypeVariables\n where\n getTypeVariables (Qualified predicates t) =\n getTypeVariablesOf getPredicateTypeVariables predicates `union`\n getTypeTypeVariables t\n\ngetPredicateTypeVariables :: Predicate Type Name -> [TypeVariable Name]\ngetPredicateTypeVariables (IsIn _ types) = getTypeVariablesOf getTypeTypeVariables types\n\ngetTypeTypeVariables :: Type Name -> [TypeVariable Name]\ngetTypeTypeVariables = getTypeVariables where\n getTypeVariables (VariableType typeVariable) = [typeVariable]\n getTypeVariables (ApplicationType type1 type2) =\n getTypeVariables type1 `union` getTypeVariables type2\n getTypeVariables _ = []\n\ngetTypeVariablesOf :: (a -> [TypeVariable Name]) -> [a] -> [TypeVariable Name]\ngetTypeVariablesOf f = nub . concatMap f\n\n-- | Get the kind of a type.\ntypeKind :: Type Name -> Kind\ntypeKind (ConstructorType typeConstructor) = typeConstructorKind typeConstructor\ntypeKind (VariableType typeVariable) = typeVariableKind typeVariable\ntypeKind (ApplicationType typ _) =\n case (typeKind typ) of\n (FunctionKind _ kind) -> kind\n k -> k\n\n--------------------------------------------------------------------------------\n-- GOOD NAMING CONVENInferON, UNSORTED\n\n-- | The monomorphism restriction is invoked when one or more of the\n-- entries in a list of implicitly typed bindings is simple, meaning\n-- that it has an alternative with no left-hand side patterns. The\n-- following function provides a way to test for this:\nrestrictImplicitlyTypedBindings :: [(ImplicitlyTypedBinding t Name l)] -> Bool\nrestrictImplicitlyTypedBindings = any simple\n where\n simple =\n any (null . alternativePatterns) . implicitlyTypedBindingAlternatives\n\n-- | The following function calculates the list of ambiguous variables\n-- and pairs each one with the list of predicates that must be\n-- satisfied by any choice of a default:\nambiguities :: [TypeVariable Name] -> [Predicate Type Name] -> [Ambiguity Name]\nambiguities typeVariables predicates =\n [ Ambiguity typeVariable (filter (elem typeVariable . getPredicateTypeVariables) predicates)\n | typeVariable <- getTypeVariablesOf getPredicateTypeVariables predicates \\\\ typeVariables\n ]\n\n-- | The unifyTypeVariable function is used for the special case of unifying a\n-- variable u with a type t.\nunifyTypeVariable :: MonadThrow m => TypeVariable Name -> Type Name -> m [Substitution Name]\nunifyTypeVariable typeVariable typ\n | typ == VariableType typeVariable = return nullSubst\n | typeVariable `elem` getTypeTypeVariables typ = throwM OccursCheckFails\n | typeVariableKind typeVariable /= typeKind typ = throwM KindMismatch\n | otherwise = return [Substitution typeVariable typ]\n\nunifyPredicates :: Predicate Type Name -> Predicate Type Name -> Maybe [Substitution Name]\nunifyPredicates = lift' unifyTypeList\n\noneWayMatchPredicate :: Predicate Type Name -> Predicate Type Name -> Maybe [Substitution Name]\noneWayMatchPredicate = lift' oneWayMatchLists\n\nunifyTypes :: MonadThrow m => Type Name -> Type Name -> m [Substitution Name]\nunifyTypes (ApplicationType l r) (ApplicationType l' r') = do\n s1 <- unifyTypes l l'\n s2 <- unifyTypes (substituteType s1 r) (substituteType s1 r')\n return (s2 @@ s1)\nunifyTypes (VariableType u) t = unifyTypeVariable u t\nunifyTypes t (VariableType u) = unifyTypeVariable u t\nunifyTypes (ConstructorType tc1) (ConstructorType tc2)\n | tc1 == tc2 = return nullSubst\nunifyTypes a b = throwM (TypeMismatch a b)\n\nunifyTypeList :: MonadThrow m => [Type Name] -> [Type Name] -> m [Substitution Name]\nunifyTypeList (x:xs) (y:ys) = do\n s1 <- unifyTypes x y\n s2 <- unifyTypeList (map (substituteType s1) xs) (map (substituteType s1) ys)\n return (s2 @@ s1)\nunifyTypeList [] [] = return nullSubst\nunifyTypeList _ _ = throwM ListsDoNotUnify\n\noneWayMatchType :: MonadThrow m => Type Name -> Type Name -> m [Substitution Name]\noneWayMatchType (ApplicationType l r) (ApplicationType l' r') = do\n sl <- oneWayMatchType l l'\n sr <- oneWayMatchType r r'\n merge sl sr\noneWayMatchType (VariableType u) t\n | typeVariableKind u == typeKind t = return [Substitution u t]\noneWayMatchType (ConstructorType tc1) (ConstructorType tc2)\n | tc1 == tc2 = return nullSubst\noneWayMatchType _ _ = throwM TypeMismatchOneWay\n\noneWayMatchLists :: MonadThrow m => [Type Name] -> [Type Name] -> m [Substitution Name]\noneWayMatchLists ts ts' = do\n ss <- sequence (zipWith oneWayMatchType ts ts')\n foldM merge nullSubst ss\n\n--------------------------------------------------------------------------------\n-- Garbage\n\nlookupName\n :: MonadThrow m\n => Name -> [(TypeSignature Type Name Name)] -> m (Scheme Type Name Type)\nlookupName name cands = go name cands where\n go n [] = throwM (NotInScope cands n)\n go i ((TypeSignature i' sc):as) =\n if i == i'\n then return sc\n else go i as\n\nenumId :: Int -> Name\nenumId n = ForallName n\n\ninferLiteralType\n :: Monad m\n => SpecialTypes Name -> Literal -> InferT m ([Predicate Type Name], Type Name)\ninferLiteralType specialTypes (CharacterLiteral _) =\n return ([], ConstructorType (specialTypesChar specialTypes))\ninferLiteralType specialTypes (IntegerLiteral _) = do\n return ([], ConstructorType (specialTypesInteger specialTypes))\ninferLiteralType specialTypes (StringLiteral _) =\n return ([], ConstructorType (specialTypesString specialTypes))\ninferLiteralType specialTypes (RationalLiteral _) = do\n return ([], ConstructorType (specialTypesRational specialTypes))\n\ninferPattern\n :: MonadThrow m\n => [TypeSignature Type Name Name] -> Pattern Type Name l\n -> InferT m (Pattern Type Name (TypeSignature Type Name l), [Predicate Type Name], [(TypeSignature Type Name Name)], Type Name)\ninferPattern signatures = go\n where\n go (BangPattern p) = do\n (p', x, y, z) <- go p\n pure (BangPattern p', x, y, z)\n go (VariablePattern l i) = do\n v <- newVariableType StarKind\n return\n ( VariablePattern (TypeSignature l (toScheme v)) i\n , []\n , [TypeSignature i (toScheme v)]\n , v)\n go (WildcardPattern l s) = do\n v <- newVariableType StarKind\n return (WildcardPattern (TypeSignature l (toScheme v)) s, [], [], v)\n go (AsPattern l i pat) = do\n (pat', ps, as, t) <- go pat\n return\n ( AsPattern (TypeSignature l (toScheme t)) i pat'\n , ps\n , (TypeSignature i (toScheme t)) : as\n , t)\n go (LiteralPattern l0 l) = do\n specialTypes <- InferT (gets inferStateSpecialTypes)\n (ps, t) <- inferLiteralType specialTypes l\n return (LiteralPattern (TypeSignature l0 (toScheme t)) l, ps, [], t)\n go (ConstructorPattern l i pats) = do\n TypeSignature _ sc <- substituteConstr signatures i\n (pats', ps, as, ts) <- inferPatterns signatures pats\n t' <- newVariableType StarKind\n (Qualified qs t) <- freshInst sc\n specialTypes <- InferT (gets inferStateSpecialTypes)\n let makeArrow :: Type Name -> Type Name -> Type Name\n a `makeArrow` b =\n ApplicationType\n (ApplicationType\n (ConstructorType (specialTypesFunction specialTypes))\n a)\n b\n unify t (foldr makeArrow t' ts)\n return\n ( ConstructorPattern (TypeSignature l (toScheme t')) i pats'\n , ps ++ qs\n , as\n , t')\n-- inferPattern (LazyPattern pat) = inferPattern pat\n\nsubstituteConstr\n :: MonadThrow m\n => [TypeSignature Type Name Name] -> Name -> m (TypeSignature Type Name Name)\nsubstituteConstr subs i =\n case find\n (\\case\n TypeSignature i' _ -> i' == i)\n subs of\n Just sig -> pure sig\n _ ->\n throwM\n (NameNotInConScope\n (filter\n (\\case\n TypeSignature (ConstructorName _ _) _ -> True\n _ -> False)\n subs)\n i)\n\ninferPatterns\n :: MonadThrow m\n => [TypeSignature Type Name Name] -> [Pattern Type Name l] -> InferT m ([Pattern Type Name (TypeSignature Type Name l)], [Predicate Type Name], [(TypeSignature Type Name Name)], [Type Name])\ninferPatterns ss pats = do\n psasts <- mapM (inferPattern ss) pats\n let ps = concat [ps' | (_,ps', _, _) <- psasts]\n as = concat [as' | (_,_, as', _) <- psasts]\n ts = [t | (_, _, _, t) <- psasts]\n pats' = [ p | (p,_,_,_) <- psasts]\n return (pats', ps, as, ts)\n\npredHead :: Predicate Type Name -> Name\npredHead (IsIn i _) = i\n\nlift'\n :: MonadThrow m\n => ([Type Name] -> [Type Name] -> m a) -> Predicate Type Name -> Predicate Type Name -> m a\nlift' m (IsIn i ts) (IsIn i' ts')\n | i == i' = m ts ts'\n | otherwise = throwM ClassMismatch\n\n-- lookupClassTypeVariables :: Map Name (Class Type Name l) -> Name -> [TypeVariable Name]\n-- lookupClassTypeVariables ce i =\n-- fromMaybe\n-- []\n-- (fmap classTypeVariables (M.lookup i ce))\n\n-- lookupClassSuperclasses :: Map Name (Class Type Name l) -> Name -> [Predicate Type Name]\n-- lookupClassSuperclasses ce i = maybe [] classSuperclasses (M.lookup i ce)\n\n-- lookupClassMethods :: Map Name (Class Type Name l) -> Name -> Map Name (Type Name)\n-- lookupClassMethods ce i = maybe mempty classMethods (M.lookup i ce)\n\n-- lookupClassInstances :: Map Name (Class Type Name l) -> Name -> [Instance Type Name l]\n-- lookupClassInstances ce i =\n-- maybe [] classInstances (M.lookup i ce)\n\ndefined :: Maybe a -> Bool\ndefined (Just _) = True\ndefined Nothing = False\n\n\n-- | Add a class to the environment. Example:\n--\n-- @\n-- env <- addClass (Name l \\\"Num\\\") [TypeVariable (Name \\\"n\\\") StarKind] [] mempty\n-- @\n--\n-- Throws 'ReadException' in the case of error.\naddClass\n :: MonadThrow m\n => Class Type Name l\n -> Map Name (Class Type Name l)\n -> m (Map Name (Class Type Name l))\naddClass (Class vs ps _ i methods) ce\n | defined (M.lookup i ce) = throwM ClassAlreadyDefined\n | any (not . defined . flip M.lookup ce . predHead) ps =\n throwM UndefinedSuperclass\n | otherwise = return (M.insert i (Class vs ps [] i methods) ce)\n\n\n-- | Add an instance of a class. Example:\n--\n-- @\n-- env <- addInstance [] (IsIn (Name \\\"Num\\\") [ConstructorType (TypeConstructor (Name \\\"Integer\\\") StarKind)]) mempty\n-- @\n--\n-- Throws 'ReadException' in the case of error.\naddInstance\n :: MonadThrow m\n => Instance Type Name l\n -> Map Name (Class Type Name l)\n -> m (Map Name (Class Type Name l))\naddInstance (Instance (Forall vs (Qualified preds p@(IsIn i _))) dict) ce =\n case M.lookup i ce of\n Nothing -> throwM NoSuchClassForInstance\n Just typeClass\n | any (overlap p) qs -> throwM OverlappingInstance\n | otherwise -> return (M.insert i c ce)\n where its = classInstances typeClass\n qs = [q | Instance (Forall _ (Qualified _ q)) _ <- its]\n ps = []\n c =\n (Class\n (classTypeVariables typeClass)\n (classSuperclasses typeClass)\n (Instance (Forall vs (Qualified (nub (ps ++ preds)) p)) dict :\n its)\n i\n (classMethods typeClass))\n\noverlap :: Predicate Type Name -> Predicate Type Name -> Bool\noverlap p q = defined (unifyPredicates p q)\n\nbySuper :: Map Name (Class Type Name l) -> Predicate Type Name -> [Predicate Type Name]\nbySuper ce p@(IsIn i ts) = p : concat (map (bySuper ce) supers)\n where\n supers =\n map\n (substitutePredicate substitutions)\n (maybe [] classSuperclasses (M.lookup i ce))\n substitutions =\n zipWith Substitution (maybe [] classTypeVariables (M.lookup i ce)) ts\n\nbyInst\n :: Map Name (Class Type Name l)\n -> Predicate Type Name\n -> Maybe ([Predicate Type Name], Dictionary Type Name l)\nbyInst ce p@(IsIn i _) =\n case M.lookup i ce of\n Nothing -> throwM NoSuchClassForInstance\n Just typeClass ->\n (msum [tryInst it | it <- classInstances typeClass])\n where\n tryInst (Instance (Forall _ (Qualified ps h)) dict) = do\n (return ())\n case oneWayMatchPredicate h p of\n Just u ->\n (Just (map (substitutePredicate u) ps, dict))\n Nothing -> Nothing\n\nentail :: Show l => Map Name (Class Type Name l) -> [Predicate Type Name] -> Predicate Type Name -> Bool\nentail ce ps p =\n any (p `elem`) (map (bySuper ce) ps) ||\n case byInst ce p of\n Nothing -> False\n Just (qs, _) -> all (entail ce ps) qs\n\nsimplify :: ([Predicate Type Name] -> Predicate Type Name -> Bool) -> [Predicate Type Name] -> [Predicate Type Name]\nsimplify ent = loop []\n where\n loop rs [] = rs\n loop rs (p:ps)\n | ent (rs ++ ps) p = loop rs ps\n | otherwise = loop (p : rs) ps\n\nreduce :: Show l => Map Name (Class Type Name l) -> [Predicate Type Name] -> [Predicate Type Name]\nreduce ce = simplify (scEntail ce) . elimTauts ce\n\nelimTauts :: Show l => Map Name (Class Type Name l) -> [Predicate Type Name] -> [Predicate Type Name]\nelimTauts ce ps = [p | p <- ps, not (entail ce [] p)]\n\nscEntail :: Map Name (Class Type Name l) -> [Predicate Type Name] -> Predicate Type Name -> Bool\nscEntail ce ps p = any (p `elem`) (map (bySuper ce) ps)\n\nquantify :: [TypeVariable Name] -> Qualified Type Name (Type Name) -> Scheme Type Name Type\nquantify vs qt = Forall vs' qt\n where\n vs' = [v | v <- getQualifiedTypeVariables qt, v `elem` vs]\n {-ks = map typeVariableKind vs'-}\n {-s = zipWith Substitution vs' (map undefined {-GenericType-} [0 ..])-}\n\ntoScheme :: Type Name -> Scheme Type Name Type\ntoScheme t = Forall [] (Qualified [] t)\n\nmerge\n :: MonadThrow m\n => [Substitution Name] -> [Substitution Name] -> m [Substitution Name]\nmerge s1 s2 =\n if agree\n then return (s1 ++ s2)\n else throwM MergeFail\n where\n agree =\n all\n (\\v -> substituteType s1 (VariableType v) == substituteType s2 (VariableType v))\n (map substitutionTypeVariable s1 `intersect`\n map substitutionTypeVariable s2)\n\ninferExpressionType\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> (Expression Type Name l)\n -> InferT m ([Predicate Type Name], Type Name, Expression Type Name (TypeSignature Type Name l))\ninferExpressionType ce as (ParensExpression l e) = do\n (ps, t, e') <- inferExpressionType ce as e\n pure (ps, t, ParensExpression (fmap (const l) (expressionLabel e')) e')\ninferExpressionType _ as (VariableExpression l i) = do\n sc <- lookupName i as\n qualified@(Qualified ps t) <- freshInst sc\n let scheme = (Forall [] qualified)\n return (ps, t, VariableExpression (TypeSignature l scheme) i)\ninferExpressionType _ _ (ConstantExpression l i) = do\n t <- newVariableType StarKind\n return ([], t, (ConstantExpression (TypeSignature l (toScheme t)) i))\ninferExpressionType _ as (ConstructorExpression l i) = do\n sc <- lookupName i as\n qualified@(Qualified ps t) <- freshInst sc\n let scheme = (Forall [] qualified)\n return (ps, t, ConstructorExpression (TypeSignature l scheme) i)\ninferExpressionType _ _ (LiteralExpression l0 l) = do\n specialTypes <- InferT (gets inferStateSpecialTypes)\n (ps, t) <- inferLiteralType specialTypes l\n let scheme = (Forall [] (Qualified ps t))\n return (ps, t, LiteralExpression (TypeSignature l0 scheme) l)\ninferExpressionType ce as (ApplicationExpression l e f) = do\n (ps, te, e') <- inferExpressionType ce as e\n (qs, tf, f') <- inferExpressionType ce as f\n t <- newVariableType StarKind\n specialTypes <- InferT (gets inferStateSpecialTypes)\n let makeArrow :: Type Name -> Type Name -> Type Name\n a `makeArrow` b = ApplicationType (ApplicationType (ConstructorType(specialTypesFunction specialTypes)) a) b\n unify (tf `makeArrow` t) te\n let scheme = (Forall [] (Qualified (ps++qs) t))\n return (ps ++ qs, t, ApplicationExpression (TypeSignature l scheme) e' f')\ninferExpressionType ce as (InfixExpression l x (i,op) y) = do\n (ps, ts, ~(ApplicationExpression l' (ApplicationExpression _ (op') x') y')) <-\n inferExpressionType\n ce\n as\n (ApplicationExpression l (ApplicationExpression l op x) y)\n pure (ps, ts, InfixExpression l' x' (i, op') y')\ninferExpressionType ce as (LetExpression l bg e) = do\n (ps, as', bg') <- inferBindGroupTypes ce as bg\n (qs, t, e') <- inferExpressionType ce (as' ++ as) e\n let scheme = (Forall [] (Qualified (ps++qs) t))\n return (ps ++ qs, t, LetExpression (TypeSignature l scheme) bg' e')\ninferExpressionType ce as (LambdaExpression l alt) = do\n (x, y, s) <- inferAltTypeForLambda ce as alt\n pure\n ( x\n , y\n , LambdaExpression\n (TypeSignature l (typeSignatureScheme (alternativeLabel s)))\n s)\ninferExpressionType ce as (IfExpression l e e1 e2) = do\n (ps, t, e') <- inferExpressionType ce as e\n specialTypes <- InferT (gets inferStateSpecialTypes)\n unify t (dataTypeConstructor (specialTypesBool specialTypes))\n (ps1, t1, e1') <- inferExpressionType ce as e1\n (ps2, t2, e2') <- inferExpressionType ce as e2\n unify t1 t2\n let scheme = (Forall [] (Qualified (ps ++ ps1 ++ ps2) t1))\n return (ps ++ ps1 ++ ps2, t1, IfExpression (TypeSignature l scheme) e' e1' e2')\ninferExpressionType ce as (CaseExpression l e branches) = do\n (ps0, t, e') <- inferExpressionType ce as e\n v <- newVariableType StarKind\n let tiBr (CaseAlt l' pat f) = do\n (pat', ps, as', t') <- inferPattern as pat\n unify t t'\n (qs, t'', f') <- inferExpressionType ce (as' ++ as) f\n unify v t''\n return\n (ps ++ qs, (CaseAlt (fmap (const l') (expressionLabel f')) pat' f'))\n branchs <- mapM tiBr branches\n let pss = map fst branchs\n branches' = map snd branchs\n let scheme = (Forall [] (Qualified (ps0 ++ concat pss) v))\n return\n (ps0 ++ concat pss, v, CaseExpression (TypeSignature l scheme) e' branches')\n\ninferAltTypeForLambda\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> Alternative Type Name l\n -> InferT m ([Predicate Type Name], Type Name, Alternative Type Name (TypeSignature Type Name l))\ninferAltTypeForLambda ce as alt =\n inferAltType0\n ce\n as\n (\\l scheme pats ex -> Alternative (TypeSignature l scheme) pats ex)\n alt\n\ninferAltTypeForBind\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> Alternative Type Name l\n -> InferT m ([Predicate Type Name], Type Name, Alternative Type Name (TypeSignature Type Name l))\ninferAltTypeForBind ce as alt =\n inferAltType0 ce as makeAltForDecl alt\n\ninferAltType0\n :: (Show t1, MonadThrow m)\n => Map Name (Class Type Name t1)\n -> [TypeSignature Type Name Name]\n -> (t1 -> Scheme Type Name Type -> [Pattern Type Name (TypeSignature Type Name t1)] -> Expression Type Name (TypeSignature Type Name t1) -> t)\n -> Alternative Type Name t1\n -> InferT m ([Predicate Type Name], Type Name, t)\ninferAltType0 ce as makeAlt (Alternative l pats e) = do\n (pats', ps, as', ts) <- inferPatterns as pats\n (qs, t, e') <- inferExpressionType ce (as' ++ as) e\n specialTypes <- InferT (gets inferStateSpecialTypes)\n let makeArrow :: Type Name -> Type Name -> Type Name\n a `makeArrow` b = ApplicationType (ApplicationType (ConstructorType(specialTypesFunction specialTypes)) a) b\n let scheme = (Forall [] (Qualified (ps ++ qs) (foldr makeArrow t ts)))\n return (ps ++ qs, foldr makeArrow t ts, makeAlt l scheme pats' e')\n\n-- | During parsing, we parse\n-- f = \\x -> x\n-- as\n-- f x = x\n-- After type-checking, we expand the lambda out again:\n--\n-- f = \\x -> x\n--\n-- But type-checked and generalized.\nmakeAltForDecl\n :: a\n -> Scheme Type i1 Type\n -> [Pattern Type i (TypeSignature Type i1 a)]\n -> Expression Type i (TypeSignature Type i1 a)\n -> Alternative Type i (TypeSignature Type i1 a)\nmakeAltForDecl l scheme pats' e' =\n if null pats'\n then Alternative (TypeSignature l scheme) pats' e'\n else Alternative\n (TypeSignature l scheme)\n []\n (LambdaExpression\n (TypeSignature l scheme)\n (Alternative (TypeSignature l scheme) pats' e'))\n\ninferAltTypes\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l)\n -> [(TypeSignature Type Name Name)]\n -> [Alternative Type Name l]\n -> Type Name\n -> InferT m ([Predicate Type Name], [Alternative Type Name (TypeSignature Type Name l)])\ninferAltTypes ce as alts t = do\n psts <- mapM (inferAltTypeForBind ce as) alts\n mapM_ (unify t) (map snd3 psts)\n return (concat (map fst3 psts), map thd3 psts)\n where snd3 (_,x,_) = x\n thd3 (_,_,x) = x\n fst3 (x,_,_) = x\n\nsplit\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l) -> [TypeVariable Name] -> [TypeVariable Name] -> [Predicate Type Name] -> m ([Predicate Type Name], [Predicate Type Name])\nsplit ce fs gs ps = do\n let ps' = reduce ce ps\n (ds, rs) = partition (all (`elem` fs) . getPredicateTypeVariables) ps'\n rs' <- defaultedPredicates ce (fs ++ gs) rs\n return (ds, rs \\\\ rs')\n\ncandidates :: (Show l)=> Map Name (Class Type Name l) -> Ambiguity Name -> [Type Name]\ncandidates ce (Ambiguity v qs) =\n [ t'\n | let is = [i | IsIn i _ <- qs]\n ts = [t | IsIn _ t <- qs]\n , all ([VariableType v] ==) ts\n , any (`elem` numClasses) is\n , all (`elem` stdClasses) is\n , t' <- [VariableType (TypeVariable (TypeName (-1) \"x\") StarKind)]-- classEnvironmentDefaults ce\n , all (entail ce []) [IsIn i [t'] | i <- is]\n ]\n where -- disabling these\n numClasses = [ForallName (-1)]\n stdClasses = [ForallName (-1)]\n\n\nwithDefaults\n :: (MonadThrow m, Show l)\n => String\n -> ([Ambiguity Name] -> [Type Name] -> a)\n -> Map Name (Class Type Name l)\n -> [TypeVariable Name]\n -> [Predicate Type Name]\n -> m a\nwithDefaults _label f ce vs ps\n | any null tss = throwM (AmbiguousInstance vps)\n | otherwise = do\n return (f vps (map head tss))\n where\n -- showp :: Show a => a -> String\n -- showp = \\x -> \"(\" ++ show x ++ \")\"\n vps = ambiguities vs ps\n tss = map (candidates ce) vps\n\ndefaultedPredicates\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l) -> [TypeVariable Name] -> [Predicate Type Name] -> m [Predicate Type Name]\ndefaultedPredicates = withDefaults \"defaultedPredicates\" (\\vps _ -> concat (map ambiguityPredicates vps))\n\ndefaultSubst\n :: (MonadThrow m, Show l)\n => Map Name (Class Type Name l) -> [TypeVariable Name] -> [Predicate Type Name] -> m [Substitution Name]\ndefaultSubst = withDefaults \"defaultSubst\" (\\vps ts -> zipWith Substitution (map ambiguityTypeVariable vps) ts)\n\n-- extSubst\n-- :: Monad m\n-- => [Substitution] -> InferT m ()\n-- extSubst s' =\n-- InferT\n-- (modify\n-- (\\s -> s {inferStateSubstitutions = s' @@ inferStateSubstitutions s}))\n\nfreshInst\n :: Monad m\n => Scheme Type Name Type -> InferT m (Qualified Type Name (Type Name))\nfreshInst (Forall ks qt) = do\n ts <- mapM (\\vorig -> (vorig, ) <$> newVariableType (typeVariableKind vorig)) ks\n return (instantiateQualified ts qt)\n"
},
{
"path": "src/Duet/Parser.hs",
"content": "{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE FlexibleContexts #-}\n-- |\n\nmodule Duet.Parser where\n\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.IO.Class\nimport Data.List\nimport qualified Data.Map.Strict as M\nimport Data.Text (Text)\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\nimport Duet.Printer\nimport Duet.Tokenizer\nimport Duet.Types\nimport Text.Parsec hiding (satisfy, anyToken)\n\nparseFile :: (MonadIO m, MonadThrow m) => FilePath -> m [Decl UnkindedType Identifier Location]\nparseFile fp = do\n t <- liftIO (T.readFile fp)\n parseText fp t\n\nparseText :: MonadThrow m => SourceName -> Text -> m [Decl UnkindedType Identifier Location]\nparseText fp inp =\n case parse tokensTokenizer fp (inp) of\n Left e -> throwM (TokenizerError e)\n Right tokens' ->\n case runParser tokensParser 0 fp tokens' of\n Left e -> throwM (ParserError e)\n Right ast -> pure ast\n\nparseTextWith\n :: (Num u, MonadThrow m)\n => Parsec [(Token, Location)] u a -> SourceName -> Text -> m a\nparseTextWith p fp inp =\n case parse tokensTokenizer fp (inp) of\n Left e -> throwM (TokenizerError e)\n Right tokens' ->\n case runParser p 0 fp tokens' of\n Left e -> throwM (ParserError e)\n Right ast -> pure ast\n\nparseType' :: Num u => SourceName -> Parsec [(Token, Location)] u b -> Text -> Either ParseError b\nparseType' fp p inp =\n case parse tokensTokenizer fp (inp) of\n Left e -> Left e\n Right tokens' ->\n case runParser p 0 fp tokens' of\n Left e -> Left e\n Right ast -> Right ast\n\ntokensParser :: TokenParser [Decl UnkindedType Identifier Location]\ntokensParser = moduleParser <* endOfTokens\n\nmoduleParser :: TokenParser [Decl UnkindedType Identifier Location]\nmoduleParser =\n many\n (varfundeclExplicit <|> fmap (uncurry DataDecl) datadecl <|>\n fmap (uncurry ClassDecl) classdecl <|>\n fmap (uncurry InstanceDecl) instancedecl)\n\nclassdecl :: TokenParser (Location, Class UnkindedType Identifier Location)\nclassdecl =\n go \"class declaration (e.g. class Show a where show a :: a -> String)\"\n where\n go = do\n u <- getState\n loc <- equalToken ClassToken\n setState (locationStartColumn loc)\n (c, _) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing) \n \"new class name e.g. Show\"\n vars <- many1 kindableTypeVariable\n mwhere <-\n fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl\n methods <-\n if mwhere\n then do\n (_, identLoc) <-\n lookAhead\n (consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)) \n \"class methods e.g. foo :: a -> Int\"\n (many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl\n else (pure [])\n setState u\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n pure\n ( loc\n , Class\n { className = Identifier (T.unpack c)\n , classTypeVariables = vars\n , classSuperclasses = []\n , classInstances = []\n , classMethods = M.fromList methods\n })\n where\n endOfDecl =\n (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n methodParser startCol = go' \"method signature e.g. foo :: a -> Y\"\n where\n go' = do\n u <- getState\n (v, p) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n when\n (locationStartColumn p /= startCol)\n (unexpected\n (\"method name at column \" ++\n show (locationStartColumn p) ++\n \", it should start at column \" ++\n show startCol ++ \" to match the others\"))\n setState startCol\n _ <- equalToken Colons \"‘::’ for method signature\"\n scheme <- parseScheme \"method type signature e.g. foo :: Int\"\n setState u\n pure (Identifier (T.unpack v), scheme)\n\nkindableTypeVariable :: Stream s m (Token, Location) => ParsecT s Int m (TypeVariable Identifier)\nkindableTypeVariable = (unkinded <|> kinded) \"type variable (e.g. ‘a’, ‘f’, etc.)\"\n where\n kinded =\n kparens\n (do t <- unkinded\n _ <- equalToken Colons\n k <- kindParser\n pure (TypeVariable (typeVariableIdentifier t) k))\n where\n kparens :: TokenParser a -> TokenParser a\n kparens p = g \"parens e.g. (x)\"\n where\n g = do\n _ <- equalToken OpenParen\n e <-\n p \"type with kind inside parentheses e.g. (t :: Type)\"\n _ <- equalToken CloseParen \"closing parenthesis ‘)’\"\n pure e\n unkinded = do\n (v, _) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing) \n \"variable name\"\n pure (TypeVariable (Identifier (T.unpack v)) StarKind)\n\nparseScheme\n :: Stream s m (Token, Location)\n => ParsecT s Int m (Scheme UnkindedType Identifier UnkindedType)\nparseScheme = do\n explicit <-\n fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False\n if explicit\n then quantified\n else do\n ty@(Qualified _ qt) <- parseQualified\n pure (Forall (nub (collectTypeVariables qt)) ty)\n where\n quantified = do\n _ <- equalToken ForallToken\n vars <- many1 kindableTypeVariable \"type variables\"\n _ <- equalToken Period\n ty <- parseQualified\n pure (Forall vars ty)\n\nparseSchemePredicate\n :: Stream s m (Token, Location)\n => ParsecT s Int m (Scheme UnkindedType Identifier (Predicate UnkindedType))\nparseSchemePredicate = do\n explicit <-\n fmap (const True) (lookAhead (equalToken ForallToken)) <|> pure False\n if explicit\n then quantified\n else do\n ty@(Qualified _ (IsIn _ qt)) <- parseQualifiedPredicate\n pure (Forall (nub (concatMap collectTypeVariables qt)) ty)\n where\n quantified = do\n _ <- equalToken ForallToken\n vars <- many1 kindableTypeVariable \"type variables\"\n _ <- equalToken Period\n ty <- parseQualifiedPredicate\n pure (Forall vars ty)\n\nparseQualified\n :: Stream s m (Token, Location)\n => ParsecT s Int m (Qualified UnkindedType Identifier (UnkindedType Identifier))\nparseQualified = do\n ty <- parsedTypeLike\n (case ty of\n ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toType x\n where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts\n _ -> do\n t <- toType ty\n pure (Qualified [] t)) \n \"qualified type e.g. Show x => x\"\n\nparseQualifiedPredicate\n :: Stream s m (Token, Location)\n => ParsecT s Int m (Qualified UnkindedType Identifier (Predicate UnkindedType Identifier))\nparseQualifiedPredicate = do\n ty <- parsedTypeLike\n (case ty of\n ParsedQualified ps x -> Qualified <$> mapM toUnkindedPred ps <*> toPredicateUnkinded x\n where toUnkindedPred (IsIn c ts) = IsIn c <$> mapM toType ts\n _ -> do\n t <- toPredicateUnkinded ty\n pure (Qualified [] t)) \n \"qualified type e.g. Show x => x\"\n\ncollectTypeVariables :: UnkindedType i -> [TypeVariable i]\ncollectTypeVariables =\n \\case\n UnkindedTypeConstructor {} -> []\n UnkindedTypeVariable i -> [TypeVariable i StarKind]\n UnkindedTypeApp f x -> collectTypeVariables f ++ collectTypeVariables x\n\ninstancedecl :: TokenParser (Location, Instance UnkindedType Identifier Location)\ninstancedecl =\n go \"instance declaration (e.g. instance Show Int where show = ...)\"\n where\n go = do\n u <- getState\n loc <- equalToken InstanceToken\n setState (locationStartColumn loc)\n predicate@(Forall _ (Qualified _ (IsIn (Identifier c) _))) <-\n parseSchemePredicate\n mwhere <-\n fmap (const True) (equalToken Where) <|> fmap (const False) endOfDecl\n methods <-\n if mwhere\n then do\n (_, identLoc) <-\n lookAhead\n (consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)) \n \"instance methods e.g. foo :: a -> Int\"\n (many1 (methodParser (locationStartColumn identLoc))) <* endOfDecl\n else (pure [])\n setState u\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n let dictName = \"$dict\" ++ c\n pure\n ( loc\n , Instance\n { instancePredicate = predicate\n , instanceDictionary =\n Dictionary (Identifier dictName) (M.fromList methods)\n })\n where\n endOfDecl =\n (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n methodParser startCol =\n go' \"method implementation e.g. foo = \\\\x -> f x\"\n where\n go' = do\n u <- getState\n (v, p) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n when\n (locationStartColumn p /= startCol)\n (unexpected\n (\"method name at column \" ++\n show (locationStartColumn p) ++\n \", it should start at column \" ++\n show startCol ++ \" to match the others\"))\n setState startCol\n _ <- equalToken Equals \"‘=’ for method declaration e.g. x = 1\"\n e <- expParser\n setState u\n pure (Identifier (T.unpack v), (p, makeAlt (expressionLabel e) e))\n\nparseType :: Stream s m (Token, Location) => ParsecT s Int m (UnkindedType Identifier)\nparseType = do\n x <- parsedTypeLike\n toType x\n\ntoPredicateUnkinded :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate UnkindedType i)\ntoPredicateUnkinded = toPredicate >=> go\n where go (IsIn c tys) = IsIn c <$> mapM toType tys\n\ntoType :: Stream s m t => ParsedType i -> ParsecT s u m (UnkindedType i)\ntoType = go\n where\n go =\n \\case\n ParsedTypeConstructor i -> pure (UnkindedTypeConstructor i)\n ParsedTypeVariable i -> pure (UnkindedTypeVariable i)\n ParsedTypeApp t1 t2 -> UnkindedTypeApp <$> go t1 <*> go t2\n ParsedQualified {} -> unexpected \"qualification context\"\n ParsedTuple {} -> unexpected \"tuple\"\n\ndatadecl :: TokenParser (Location, DataType UnkindedType Identifier)\ndatadecl = go \"data declaration (e.g. data Maybe a = Just a | Nothing)\"\n where\n go = do\n loc <- equalToken Data\n (v, _) <-\n consumeToken\n (\\case\n Constructor i -> Just i\n _ -> Nothing) \n \"new type name (e.g. Foo)\"\n vs <- many kindableTypeVariable\n _ <- equalToken Equals\n cs <- sepBy1 consp (equalToken Bar)\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n pure (loc, DataType (Identifier (T.unpack v)) vs cs)\n\nkindParser :: Stream s m (Token, Location) => ParsecT s Int m Kind\nkindParser = infix'\n where\n infix' = do\n left <- star\n tok <-\n fmap Just (operator (\"arrow \" ++ curlyQuotes \"->\")) <|> pure Nothing\n case tok of\n Just (RightArrow, _) -> do\n right <-\n kindParser \n (\"right-hand side of function arrow \" ++ curlyQuotes \"->\")\n pure (FunctionKind left right)\n _ -> pure left\n where\n operator =\n satisfyToken\n (\\case\n RightArrow {} -> True\n _ -> False)\n star = do\n (c, _) <-\n consumeToken\n (\\case\n Constructor c\n | c == \"Type\" -> Just StarKind\n _ -> Nothing)\n pure c\n\nconsp :: TokenParser (DataTypeConstructor UnkindedType Identifier)\nconsp = do c <- consParser\n slots <- many slot\n pure (DataTypeConstructor c slots)\n where consParser = go \"value constructor (e.g. Just)\"\n where\n go = do\n (c, _) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing)\n pure\n (Identifier (T.unpack c))\n\nslot :: TokenParser (UnkindedType Identifier)\nslot = consParser <|> variableParser <|> parens parseType\n where\n variableParser = go \"type variable (e.g. ‘a’, ‘s’, etc.)\"\n where\n go = do\n (v, _) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n pure (UnkindedTypeVariable (Identifier (T.unpack v)))\n consParser = go \"type constructor (e.g. Maybe)\"\n where\n go = do\n (c, _) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing)\n pure (UnkindedTypeConstructor (Identifier (T.unpack c)))\n\ndata ParsedType i\n = ParsedTypeConstructor i\n | ParsedTypeVariable i\n | ParsedTypeApp (ParsedType i) (ParsedType i)\n | ParsedQualified [Predicate ParsedType i] (ParsedType i)\n | ParsedTuple [ParsedType i]\n deriving (Show)\n\nparsedTypeLike :: TokenParser (ParsedType Identifier)\nparsedTypeLike = infix' <|> app <|> unambiguous\n where\n infix' = do\n left <- (app <|> unambiguous) \"left-hand side of function arrow\"\n tok <-\n fmap Just (operator (\"function arrow \" ++ curlyQuotes \"->\")) <|>\n fmap Just (operator2 (\"constraint arrow \" ++ curlyQuotes \"=>\")) <|>\n pure Nothing\n case tok of\n Just (RightArrow, _) -> do\n right <-\n parsedTypeLike \n (\"right-hand side of function arrow \" ++ curlyQuotes \"->\")\n pure\n (ParsedTypeApp\n (ParsedTypeApp (ParsedTypeConstructor (Identifier \"(->)\")) left)\n right)\n Just (Imply, _) -> do\n left' <- parsedTypeToPredicates left \"constraints e.g. Show a or (Read a, Show a)\"\n right <-\n parsedTypeLike \n (\"right-hand side of constraints \" ++ curlyQuotes \"=>\")\n pure (ParsedQualified left' right)\n _ -> pure left\n where\n operator =\n satisfyToken\n (\\case\n RightArrow {} -> True\n _ -> False)\n operator2 =\n satisfyToken\n (\\case\n Imply {} -> True\n _ -> False)\n app = do\n f <- unambiguous\n args <- many unambiguous\n pure (foldl' ParsedTypeApp f args)\n unambiguous =\n atomicType <|>\n parensTy\n (do xs <- sepBy1 parsedTypeLike (equalToken Comma)\n case xs of\n [x] -> pure x\n _ -> pure (ParsedTuple xs))\n atomicType = consParse <|> varParse\n consParse = do\n (v, _) <-\n consumeToken\n (\\case\n Constructor i -> Just i\n _ -> Nothing) \n \"type constructor (e.g. Int, Maybe)\"\n pure (ParsedTypeConstructor (Identifier (T.unpack v)))\n varParse = do\n (v, _) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing) \n \"type variable (e.g. a, f)\"\n pure (ParsedTypeVariable (Identifier (T.unpack v)))\n parensTy p = go \"parentheses e.g. (T a)\"\n where\n go = do\n _ <- equalToken OpenParen\n e <- p \"type inside parentheses e.g. (Maybe a)\"\n _ <- equalToken CloseParen \"closing parenthesis ‘)’\"\n pure e\n\nparsedTypeToPredicates :: Stream s m t => ParsedType i -> ParsecT s u m [Predicate ParsedType i]\nparsedTypeToPredicates =\n \\case\n ParsedTuple xs -> mapM toPredicate xs\n x -> fmap return (toPredicate x)\n\ntoPredicate :: Stream s m t => ParsedType i -> ParsecT s u m (Predicate ParsedType i)\ntoPredicate t =\n case targs t of\n (ParsedTypeConstructor i, vars@(_:_)) -> do\n pure (IsIn i vars)\n _ -> unexpected \"non-class constraint\"\n\ntoVar :: Stream s m t1 => ParsedType t -> ParsecT s u m (ParsedType t)\ntoVar =\n \\case\n v@ParsedTypeVariable {} -> pure v\n _ -> unexpected \"non-type-variable\"\n\ntargs :: ParsedType t -> (ParsedType t, [ParsedType t])\ntargs e = go e []\n where\n go (ParsedTypeApp f x) args = go f (x : args)\n go f args = (f, args)\n\nvarfundecl :: TokenParser (ImplicitlyTypedBinding UnkindedType Identifier Location)\nvarfundecl = go \"variable declaration (e.g. x = 1, f = \\\\x -> x * x)\"\n where\n go = do\n (v, loc) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing) \n \"variable name\"\n _ <- equalToken Equals \"‘=’ for variable declaration e.g. x = 1\"\n e <- expParser\n _ <- (pure () <* satisfyToken (==NonIndentedNewline)) <|> endOfTokens\n pure (ImplicitlyTypedBinding loc (Identifier (T.unpack v), loc) [makeAlt loc e])\n\nvarfundeclExplicit :: TokenParser (Decl UnkindedType Identifier Location)\nvarfundeclExplicit =\n go \"explicitly typed variable declaration (e.g. x :: Int and x = 1)\"\n where\n go = do\n (v0, loc) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing) \n \"variable name\"\n (tok, _) <- anyToken curlyQuotes \"::\" ++ \" or \" ++ curlyQuotes \"=\"\n case tok of\n Colons -> do\n scheme <- parseScheme \"type signature e.g. foo :: Int\"\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n (v, _) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing) \n \"variable name\"\n when\n (v /= v0)\n (unexpected \"variable binding name different to the type signature\")\n _ <- equalToken Equals \"‘=’ for variable declaration e.g. x = 1\"\n e <- expParser\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n pure\n (BindDecl\n loc\n (ExplicitBinding\n (ExplicitlyTypedBinding loc\n (Identifier (T.unpack v), loc)\n scheme\n [makeAlt loc e])))\n Equals -> do\n e <- expParser\n _ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens\n pure\n (BindDecl\n loc\n (ImplicitBinding\n (ImplicitlyTypedBinding\n loc\n (Identifier (T.unpack v0), loc)\n [makeAlt loc e])))\n t -> unexpected (tokenStr t)\n\n\nmakeAlt :: l -> Expression t i l -> Alternative t i l\nmakeAlt loc e =\n case e of\n LambdaExpression _ alt -> alt\n _ -> Alternative loc [] e\n\ncase' :: TokenParser (Expression UnkindedType Identifier Location)\ncase' = do\n u <- getState\n loc <- equalToken Case\n setState (locationStartColumn loc)\n e <- expParser \"expression to do case analysis e.g. case e of ...\"\n _ <- equalToken Of\n p <- lookAhead altPat \"case pattern\"\n alts <- many (altParser (Just e) (locationStartColumn (patternLabel p)))\n setState u\n pure (CaseExpression loc e alts)\n\naltsParser\n :: Stream s m (Token, Location)\n => ParsecT s Int m [(CaseAlt UnkindedType Identifier Location)]\naltsParser = many (altParser Nothing 1)\n\naltParser\n :: Maybe (Expression UnkindedType Identifier Location)\n -> Int\n -> TokenParser (CaseAlt UnkindedType Identifier Location)\naltParser e' startCol =\n (do u <- getState\n p <- altPat\n when\n (locationStartColumn (patternLabel p) /= startCol)\n (unexpected\n (\"pattern at column \" ++\n show (locationStartColumn (patternLabel p)) ++\n \", it should start at column \" ++\n show startCol ++ \" to match the others\"))\n setState startCol\n _ <- equalToken RightArrow\n e <- expParser\n setState u\n pure (CaseAlt (Location 0 0 0 0) p e)) \n (\"case alternative\" ++\n (case e' of\n Just eeee ->\n \" e.g.\\n\\ncase \" ++\n printExpression defaultPrint eeee ++\n \" of\\n Just bar -> bar\"\n Nothing -> \"\"))\n\naltPat :: TokenParser (Pattern UnkindedType Identifier Location)\naltPat = bang <|> varp <|> intliteral <|> consParser <|> stringlit\n where\n bang =\n (BangPattern <$>\n (consumeToken\n (\\case\n Bang -> Just Bang\n _ -> Nothing) *>\n patInner)) \"bang pattern\"\n patInner = parenpat <|> varp <|> intliteral <|> unaryConstructor\n parenpat = go\n where\n go = do\n _ <- equalToken OpenParen\n e <- varp <|> altPat\n _ <- equalToken CloseParen \"closing parenthesis ‘)’\"\n pure e\n intliteral = go \"integer (e.g. 42, 123)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Integer c -> Just c\n _ -> Nothing)\n pure (LiteralPattern loc (IntegerLiteral c))\n stringlit = go \"string (e.g. 42, 123)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n String c -> Just c\n _ -> Nothing)\n pure (LiteralPattern loc (StringLiteral (T.unpack c)))\n varp = go \"variable pattern (e.g. x)\"\n where\n go = do\n (v, loc) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n pure\n (if T.isPrefixOf \"_\" v\n then WildcardPattern loc (T.unpack v)\n else VariablePattern loc (Identifier (T.unpack v)))\n unaryConstructor = go \"unary constructor (e.g. Nothing)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing)\n pure (ConstructorPattern loc (Identifier (T.unpack c)) [])\n consParser = go \"constructor pattern (e.g. Just x)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing)\n args <- many patInner\n pure (ConstructorPattern loc (Identifier (T.unpack c)) args)\n\nexpParser :: TokenParser (Expression UnkindedType Identifier Location)\nexpParser = case' <|> lambda <|> ifParser <|> infix' <|> app <|> atomic\n where\n app = do\n left <- funcOp \"function expression\"\n right <- many unambiguous \"function arguments\"\n case right of\n [] -> pure left\n _ -> pure (foldl (ApplicationExpression (Location 0 0 0 0)) left right)\n infix' =\n (do left <- (app <|> unambiguous) \"left-hand side of operator\"\n tok <- fmap Just (operator \"infix operator\") <|> pure Nothing\n case tok of\n Just (Operator t, _) -> do\n right <-\n (app <|> unambiguous) \n (\"right-hand side of \" ++\n curlyQuotes (T.unpack t) ++ \" operator\")\n badop <- fmap Just (lookAhead operator) <|> pure Nothing\n let infixexp =\n InfixExpression\n (Location 0 0 0 0)\n left\n (let i = ((T.unpack t))\n in (i, VariableExpression (Location 0 0 0 0) (Identifier i)))\n right\n maybe\n (return ())\n (\\op ->\n unexpected\n (concat\n [ tokenString op ++\n \". When more than one operator is used\\n\"\n , \"in the same expression, use parentheses, like this:\\n\"\n , \"(\" ++\n printExpression defaultPrint infixexp ++\n \") \" ++\n (case op of\n (Operator i, _) -> T.unpack i ++ \" ...\"\n _ -> \"* ...\") ++\n \"\\n\"\n , \"Or like this:\\n\"\n , printExpressionAppArg defaultPrint left ++\n \" \" ++\n T.unpack t ++\n \" (\" ++\n printExpressionAppArg defaultPrint right ++\n \" \" ++\n case op of\n (Operator i, _) -> T.unpack i ++ \" ...)\"\n _ -> \"* ...)\"\n ]))\n badop\n pure infixexp\n _ -> pure left) \n \"infix expression (e.g. x * y)\"\n where\n operator =\n satisfyToken\n (\\case\n Operator {} -> True\n _ -> False)\n funcOp = varParser <|> constructorParser <|> parensExpr\n unambiguous = parensExpr <|> atomic\n parensExpr = parens expParser\n\noperatorParser\n :: Stream s m (Token, Location)\n => ParsecT s Int m (String, Expression t Identifier Location)\noperatorParser = do\n tok <-\n satisfyToken\n (\\case\n Operator {} -> True\n _ -> False)\n pure\n (case tok of\n (Operator t, _) ->\n let i = (T.unpack t)\n in (i, VariableExpression (Location 0 0 0 0) (Identifier i))\n _ -> error \"should be operator...\")\n\nlambda :: TokenParser (Expression UnkindedType Identifier Location)\nlambda = do\n loc <- equalToken Backslash \"lambda expression (e.g. \\\\x -> x)\"\n args <- many1 funcParam \"lambda parameters\"\n _ <- equalToken RightArrow\n e <- expParser\n pure (LambdaExpression loc (Alternative loc args e))\n\nfuncParams :: TokenParser [Pattern UnkindedType Identifier Location]\nfuncParams = many1 funcParam\n\nfuncParam :: TokenParser (Pattern UnkindedType Identifier Location)\nfuncParam = go \"function parameter (e.g. ‘x’, ‘limit’, etc.)\"\n where\n go = do\n (v, loc) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n pure (VariablePattern loc (Identifier (T.unpack v)))\n\natomic :: TokenParser (Expression UnkindedType Identifier Location)\natomic =\n varParser <|> charParser <|> stringParser <|> integerParser <|> decimalParser <|>\n constructorParser\n where\n charParser = go \"character (e.g. 'a')\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Character c -> Just c\n _ -> Nothing)\n pure (LiteralExpression loc (CharacterLiteral c))\n stringParser = go \"string (e.g. \\\"a\\\")\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n String c -> Just c\n _ -> Nothing)\n pure (LiteralExpression loc (StringLiteral (T.unpack c)))\n\n integerParser = go \"integer (e.g. 42, 123)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Integer c -> Just c\n _ -> Nothing)\n pure (LiteralExpression loc (IntegerLiteral c))\n decimalParser = go \"decimal (e.g. 42, 123)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Decimal c -> Just c\n _ -> Nothing)\n pure (LiteralExpression loc (RationalLiteral (realToFrac c)))\n\nconstructorParser :: TokenParser (Expression UnkindedType Identifier Location)\nconstructorParser = go \"constructor (e.g. Just)\"\n where\n go = do\n (c, loc) <-\n consumeToken\n (\\case\n Constructor c -> Just c\n _ -> Nothing)\n pure\n (ConstructorExpression loc (Identifier (T.unpack c)))\n\nparens :: TokenParser a -> TokenParser a\nparens p = go \"parens e.g. (x)\"\n where go = do\n _ <- equalToken OpenParen\n e <- p \"expression inside parentheses e.g. (foo)\"\n _ <- equalToken CloseParen \"closing parenthesis ‘)’\"\n pure e\n\nvarParser :: TokenParser (Expression UnkindedType Identifier Location)\nvarParser = go \"variable (e.g. ‘foo’, ‘id’, etc.)\"\n where\n go = do\n (v, loc) <-\n consumeToken\n (\\case\n Variable i -> Just i\n _ -> Nothing)\n pure (if T.isPrefixOf \"_\" v\n then ConstantExpression loc (Identifier (T.unpack v))\n else VariableExpression loc (Identifier (T.unpack v)))\n\nifParser :: TokenParser (Expression UnkindedType Identifier Location)\nifParser = go \"if expression (e.g. ‘if p then x else y’)\"\n where\n go = do\n loc <- equalToken If\n p <- expParser \"condition expresion of if-expression\"\n _ <- equalToken Then \"‘then’ keyword for if-expression\"\n e1 <- expParser \"‘then’ clause of if-expression\"\n _ <- equalToken Else \"‘else’ keyword for if-expression\"\n e2 <- expParser \"‘else’ clause of if-expression\"\n pure\n (IfExpression\n loc\n { locationEndLine = locationEndLine (expressionLocation loc e2)\n , locationEndColumn = locationEndColumn (expressionLocation loc e2)\n }\n p\n e1\n e2)\n expressionLocation nil e = foldr const nil e\n"
},
{
"path": "src/Duet/Printer.hs",
"content": "{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE KindSignatures #-}\n{-# LANGUAGE ViewPatterns #-}\n{-# LANGUAGE Strict #-}\n{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- |\n\nmodule Duet.Printer where\n\nimport Data.Char\nimport Data.List\nimport qualified Data.Map.Strict as M\nimport Duet.Types\nimport Text.Printf\n\nclass PrintableType (t :: * -> *) where\n printType :: Printable i => Print i l -> SpecialTypes i -> t i -> String\n\ninstance PrintableType (Predicate Type) where\n printType = printPredicate\n\nclass (Eq a, Identifiable a) => Printable a where\n printit :: Print i l -> a -> String\n\ninstance Printable Name where\n printit printer =\n \\case\n PrimopName primop -> printPrimop primop\n ValueName i string ->\n string ++\n (if printNameDetails printer\n then \"[value:\" ++ show i ++ \"]\"\n else \"\")\n TypeName i string ->\n string ++\n (if printNameDetails printer\n then \"[type:\" ++ show i ++ \"]\"\n else \"\")\n ConstructorName i string ->\n string ++\n (if printNameDetails printer\n then \"[constructor:\" ++ show i ++ \"]\"\n else \"\")\n ForallName i -> \"g\" ++ show i\n DictName i string ->\n string ++\n (if printNameDetails printer\n then \"[dict:\" ++ show i ++ \"]\"\n else \"\")\n ClassName i s ->\n s ++\n (if printNameDetails printer\n then \"[class:\" ++ show i ++ \"]\"\n else \"\")\n MethodName i s ->\n s ++\n (if printNameDetails printer\n then \"[method:\" ++ show i ++ \"]\"\n else \"\")\n\nprintPrimop :: Primop -> [Char]\nprintPrimop =\n \\case\n PrimopIntegerSubtract -> \"subtract\"\n PrimopIntegerTimes -> \"times\"\n PrimopIntegerPlus -> \"plus\"\n PrimopRationalSubtract -> \"subtract\"\n PrimopRationalTimes -> \"times\"\n PrimopRationalPlus -> \"plus\"\n PrimopRationalDivide -> \"divide\"\n PrimopStringAppend -> \"append\"\n PrimopStringDrop -> \"drop\"\n PrimopStringTake -> \"take\"\n\ninstance Printable Identifier where\n printit _ =\n \\case\n Identifier string -> string\n\ndefaultPrint :: Print i b\ndefaultPrint =\n Print\n { printDictionaries = False\n , printTypes = const Nothing\n , printNameDetails = False\n }\n\ndata Print i l = Print\n { printTypes :: (l -> Maybe (SpecialTypes i, TypeSignature Type i ()))\n , printDictionaries :: Bool\n , printNameDetails :: Bool\n }\n\nprintDataType :: (Printable i, PrintableType t) => Print i l -> SpecialTypes i -> DataType t i -> String\nprintDataType printer specialTypes (DataType name vars cons) =\n \"data \" ++ printit printer name ++ \" \" ++ unwords (map (printTypeVariable printer) vars) ++ \"\\n = \" ++\n intercalate \"\\n | \" (map (printConstructor printer specialTypes) cons)\n\nprintConstructor :: (Printable i, PrintableType t) => Print i l -> SpecialTypes i -> DataTypeConstructor t i -> [Char]\nprintConstructor printer specialTypes (DataTypeConstructor name fields) =\n printit printer name ++ \" \" ++ unwords (map (printType printer specialTypes) fields)\n\nprintTypeSignature\n :: (Printable i, Printable j)\n => Print i l -> SpecialTypes i -> TypeSignature Type i j -> String\nprintTypeSignature printer specialTypes (TypeSignature thing scheme) =\n printit printer thing ++ \" :: \" ++ printScheme printer specialTypes scheme\n\nprintIdentifier :: Printable j => Print i l -> j -> String\nprintIdentifier printer = printit printer\n\nprintImplicitlyTypedBinding\n :: (Printable i, PrintableType t)\n => Print i l -> ImplicitlyTypedBinding t i l -> String\nprintImplicitlyTypedBinding printer (ImplicitlyTypedBinding _ (i, _) [alt]) =\n printIdentifier printer i ++ \" \" ++ printAlternative printer alt\nprintImplicitlyTypedBinding _ _ = \"\"\n\nprintExplicitlyTypedBinding\n :: (Printable i, PrintableType t)\n => Print i l -> SpecialTypes i -> ExplicitlyTypedBinding t i l -> String\nprintExplicitlyTypedBinding printer specialTypes (ExplicitlyTypedBinding _ (i, _) scheme [alt]) =\n printIdentifier printer i ++ \" :: \" ++ printScheme printer specialTypes scheme ++ \"\\n\" ++\n printIdentifier printer i ++ \" \" ++ printAlternative printer alt\nprintExplicitlyTypedBinding _ _ _ = \"\"\n\nprintAlternative :: (Printable i, PrintableType t) => Print i l -> Alternative t i l -> [Char]\nprintAlternative printer (Alternative _ patterns expression) =\n concat (map (\\p->printPattern printer p ++ \" \") patterns) ++ \"= \" ++ printExpression printer expression\n\nprintPattern :: (Printable i, PrintableType t) => Print i l -> Pattern t i l -> [Char]\nprintPattern printer =\n \\case\n BangPattern p -> \"!\" ++ printPattern printer p\n VariablePattern _ i -> printIdentifier printer i\n WildcardPattern _ s -> s\n AsPattern _ i p -> printIdentifier printer i ++ \"@\" ++ printPattern printer p\n LiteralPattern _ l -> printLiteral l\n ConstructorPattern _ i pats ->\n printIdentifier printer i ++ \" \" ++ unwords (map (printPattern printer) pats)\n\nprintExpression :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String\nprintExpression printer e =\n wrapType\n (case e of\n LiteralExpression _ l -> printLiteral l\n VariableExpression _ i -> printIdentifier printer i\n ConstantExpression _ i -> printIdentifier printer i\n ConstructorExpression _ i -> printIdentifier printer i\n ParensExpression _ e -> \"(\" <> (printExpression printer e) <> \")\"\n CaseExpression _ e alts ->\n \"case \" ++\n indent 5 (printExpressionIfPred printer e) ++\n \" of\\n\" ++ indented (intercalate \"\\n\" (map (printAlt printer) alts))\n ApplicationExpression _ f x ->\n case x of\n VariableExpression _ (nonrenamableName -> Just (DictName {}))\n | not (printDictionaries printer) -> printExpressionAppOp printer f\n _ ->\n if any (== '\\n') inner || any (== '\\n') prefix\n then prefix ++ \"\\n\" ++ indented inner\n else prefix ++ \" \" ++ indent (length prefix + 1) inner\n where prefix = printExpressionAppOp printer f\n inner = printExpressionAppArg printer x\n LambdaExpression _ (Alternative _ args e) ->\n if null filteredArgs\n then inner\n else if any (== '\\n') inner\n then \"\\\\\" ++ prefix ++ \"->\\n\" ++ indented inner\n else \"\\\\\" ++\n prefix ++ \"-> \" ++ indent (length prefix + 4) inner\n where inner = (printExpression printer e)\n filteredArgs = filter dictPred args\n prefix =\n concat (map (\\x -> printPattern printer x ++ \" \") filteredArgs)\n dictPred =\n if printDictionaries printer\n then const True\n else \\case\n VariablePattern _ (nonrenamableName -> Just (DictName {})) ->\n False\n _ -> True\n IfExpression _ a b c ->\n \"if \" ++\n printExpressionIfPred printer a ++\n \" then \" ++\n printExpression printer b ++ \" else \" ++ printExpression printer c\n InfixExpression _ f (o, ov) x ->\n printExpressionAppArg printer f ++\n \" \" ++\n (if printDictionaries printer\n then \"`\" ++ printExpression printer ov ++ \"`\"\n else o) ++\n \" \" ++ printExpressionAppArg printer x\n _ -> \"\")\n where\n wrapType x =\n case printTypes printer (expressionLabel e) of\n (Nothing) -> x\n (Just (specialTypes, TypeSignature _ ty)) ->\n \"(\" ++\n parens x ++ \" :: \" ++ printScheme printer specialTypes ty ++ \")\"\n where parens k =\n if any isSpace k\n then \"(\" ++ k ++ \")\"\n else k\n\nprintAlt\n :: (PrintableType t, Printable i)\n => Print i l -> (CaseAlt t i l) -> [Char]\nprintAlt printer =\n \\(CaseAlt _ p e') ->\n let inner = printExpression printer e'\n in if any (== '\\n') inner\n then printPat printer p ++ \" ->\\n\" ++ indented inner\n else printPat printer p ++ \" -> \" ++ indent 2 inner\n\nindented :: String -> [Char]\nindented x = intercalate \"\\n\" (map (\" \"++) (lines x))\n\nindent :: Int -> String -> [Char]\nindent n = intercalate (\"\\n\" ++ replicate n ' ') . lines\n\nlined :: [[Char]] -> [Char]\nlined = intercalate \"\\n \"\n\nprintPat :: (Printable i, PrintableType t) => Print i l -> Pattern t i l -> String\nprintPat printer=\n \\case\n BangPattern p -> \"!\" ++ printPat printer p\n VariablePattern _ i -> printit printer i\n ConstructorPattern _ i ps ->\n printit printer i ++\n (if null ps\n then \"\"\n else \" \" ++ unwords (map inner ps))\n WildcardPattern{} -> \"_\"\n AsPattern _ ident p -> printit printer ident ++ \"@\" ++ printPat printer p\n LiteralPattern _ l -> printLiteral l\n where\n inner =\n \\case\n BangPattern p -> \"!\" ++ inner p\n VariablePattern _ i -> printit printer i\n WildcardPattern _ s -> s\n ConstructorPattern _ i ps\n | null ps -> printit printer i\n | otherwise ->\n \"(\" ++ printit printer i ++ \" \" ++ unwords (map inner ps) ++ \")\"\n AsPattern _ ident p -> printit printer ident ++ \"@\" ++ printPat printer p\n LiteralPattern _ l -> printLiteral l\n\nprintExpressionAppArg :: (Printable i, PrintableType t) => Print i l ->(Expression t i l) -> String\nprintExpressionAppArg printer =\n \\case\n e@(ApplicationExpression {})\n | nodict e -> paren (printExpression printer e)\n e@(IfExpression {}) -> paren (printExpression printer e)\n e@(InfixExpression {}) -> paren (printExpression printer e)\n e@(LambdaExpression {}) -> paren (printExpression printer e)\n e@(CaseExpression {}) -> paren (printExpression printer e)\n e -> printExpression printer e\n where\n nodict =\n \\case\n ApplicationExpression _ _ (VariableExpression _ (nonrenamableName -> Just (DictName {})))\n | not (printDictionaries printer) -> False\n _ -> True\n\nprintExpressionIfPred :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String\nprintExpressionIfPred printer=\n \\case\n e@(IfExpression {}) -> paren (printExpression printer e)\n e@(LambdaExpression {}) -> paren (printExpression printer e)\n e@(CaseExpression {}) -> paren (printExpression printer e)\n e -> printExpression printer e\n\nprintExpressionAppOp :: (Printable i, PrintableType t) => Print i l -> (Expression t i l) -> String\nprintExpressionAppOp printer=\n \\case\n e@(IfExpression {}) -> paren (printExpression printer e)\n e@(LambdaExpression {}) -> paren (printExpression printer e)\n e@(CaseExpression {}) -> paren (printExpression printer e)\n e -> printExpression printer e\n\nparen :: [Char] -> [Char]\nparen e = \"(\" ++ indent 1 e ++ \")\"\n\nprintLiteral :: Literal -> String\nprintLiteral (IntegerLiteral i) = show i\nprintLiteral (RationalLiteral i) = printf \"%f\" (fromRational i :: Double)\nprintLiteral (StringLiteral x) = show x\nprintLiteral (CharacterLiteral x) = show x\n\nprintScheme :: (Printable i, PrintableType t, PrintableType t1) => Print i l -> SpecialTypes i -> Scheme t i t1 -> [Char]\nprintScheme printer specialTypes (Forall kinds qualifiedType') =\n (if null kinds\n then \"\"\n else \"forall \" ++\n unwords\n (zipWith\n (\\_i k ->\n printTypeVariable\n (Print\n { printTypes = const Nothing\n , printDictionaries = False\n , printNameDetails = printNameDetails printer\n })\n k)\n [0 :: Int ..]\n kinds) ++\n \". \") ++\n printQualifiedType specialTypes qualifiedType'\n where\n printQualifiedType specialTypes (Qualified predicates typ) =\n case predicates of\n [] -> printType printer specialTypes typ\n _ ->\n \"(\" ++\n intercalate\n \", \"\n (map (printPredicate printer specialTypes) predicates) ++\n \") => \" ++ printType printer specialTypes typ\n\n\nprintClass :: Printable i => Print i l -> SpecialTypes i -> Class Type i l -> String\nprintClass printer specialTypes (Class vars supers instances i methods) =\n \"class \" ++\n printSupers printer specialTypes supers ++\n printit printer i ++\n \" \" ++\n unwords (map (printTypeVariable printer) vars) ++ \" where\\n \" ++\n intercalate \"\\n \" (map (printMethod printer specialTypes) (M.toList methods)) ++\n \"\\n\" ++ intercalate \"\\n\" (map (printInstance printer specialTypes) instances)\n\nprintMethod :: Printable i => Print i l -> SpecialTypes i -> (i, Scheme Type i Type) -> String\nprintMethod printer specialTypes (i, scheme) =\n printit printer i ++ \" :: \" ++ printScheme printer specialTypes scheme\n\nprintInstance :: Printable i => Print i l -> SpecialTypes i -> Instance Type i l -> String\nprintInstance printer specialTypes (Instance scheme _) =\n \"instance \" ++\n printScheme printer specialTypes scheme\n\nprintSupers :: Printable i => Print i l -> SpecialTypes i -> [Predicate Type i] -> [Char]\nprintSupers printer specialTypes supers\n | null supers = \"\"\n | otherwise =\n \"(\" ++ intercalate \", \" (map (printPredicate printer specialTypes) supers) ++ \") => \"\n\n\nprintPredicate :: (Printable i, PrintableType t) => Print i l -> SpecialTypes i -> Predicate t i -> [Char]\nprintPredicate printer specialTypes (IsIn identifier types) =\n printIdentifier printer identifier ++\n \" \" ++ unwords (map (wrap . printType printer specialTypes) types)\n where wrap x = if any isSpace x\n then \"(\" ++ x ++ \")\"\n else x\n\nprintKind :: Kind -> [Char]\nprintKind =\n \\case\n StarKind -> \"Type\"\n FunctionKind x' y -> printKind x' ++ \" -> \" ++ printKind y\n\nprintTypeSansParens :: (Printable i) => Print i l -> SpecialTypes i -> Type i -> [Char]\nprintTypeSansParens printer specialTypes =\n \\case\n ApplicationType (ApplicationType func x') y'\n | func == ConstructorType (specialTypesFunction specialTypes) ->\n printType printer specialTypes x' ++\n \" -> \" ++ printTypeSansParens printer specialTypes y'\n o -> printType printer specialTypes o\n\ninstance PrintableType Type where\n printType printer specialTypes =\n \\case\n VariableType v -> printTypeVariable printer v\n ConstructorType tyCon -> printTypeConstructor printer tyCon\n ApplicationType (ApplicationType func x') y\n | func == ConstructorType (specialTypesFunction specialTypes) ->\n \"(\" ++\n printType printer specialTypes x' ++\n \" -> \" ++ printTypeSansParens printer specialTypes y ++ \")\"\n -- ApplicationType list ty | list == specialTypesList specialTypes ->\n -- \"[\" ++ printTypeSansParens specialTypes ty ++ \"]\"\n ApplicationType x' y ->\n printType printer specialTypes x' ++ \" \" ++ printTypeArg y\n -- GenericType int -> \"g\" ++ show int\n where\n printTypeArg =\n \\case\n x@ApplicationType {} -> \"(\" ++ printType printer specialTypes x ++ \")\"\n x -> printType printer specialTypes x\n\ninstance PrintableType UnkindedType where\n printType printer specialTypes =\n \\case\n UnkindedTypeVariable v -> printIdentifier printer v\n UnkindedTypeConstructor tyCon -> printIdentifier printer tyCon\n UnkindedTypeApp x' y ->\n \"(\" ++ printType printer specialTypes x' ++ \" \" ++ printType printer specialTypes y ++ \")\"\n\nprintTypeConstructor :: Printable j => Print i l -> TypeConstructor j -> String\nprintTypeConstructor printer (TypeConstructor identifier kind) =\n case kind of\n StarKind -> printIdentifier printer identifier\n FunctionKind {} -> printIdentifier printer identifier\n -- _ -> \"(\" ++ printIdentifier identifier ++ \" :: \" ++ printKind kind ++ \")\"\n\nprintTypeVariable :: Printable i => Print i l -> TypeVariable i -> String\nprintTypeVariable printer (TypeVariable identifier kind) =\n case kind of\n StarKind -> printIdentifier printer identifier\n _ -> \"(\" ++ printIdentifier printer identifier ++ \" :: \" ++ printKind kind ++ \")\"\n\ncurlyQuotes :: [Char] -> [Char]\ncurlyQuotes t = \"‘\" <> t <> \"’\"\n"
},
{
"path": "src/Duet/Renamer.hs",
"content": "{-# LANGUAGE MultiWayIf #-}\n{-# LANGUAGE ViewPatterns #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE FlexibleContexts #-}\n\n-- At each binding point (lambdas), we need to supply a new unique\n-- name, and then rename everything inside the expression.\n--\n-- For each BindGroup, we should generate the list of unique names\n-- first for each top-level thing (which might be mutually\n-- independent), and then run the sub-renaming processes, with the new\n-- substitutions in scope.\n--\n-- It's as simple as that.\n\nmodule Duet.Renamer\n ( renameDataTypes\n , renameBindings\n , renameBindGroups\n , renameExpression\n , renameClass\n , renameInstance\n , predicateToDict\n , operatorTable\n , Specials(Specials)\n ) where\n\nimport Control.Arrow\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport Control.Monad.Trans\nimport Control.Monad.Writer\nimport Data.Char\nimport Data.List\nimport Data.Map.Strict (Map)\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Duet.Infer\nimport Duet.Printer\nimport Duet.Supply\nimport Duet.Types\n\n--------------------------------------------------------------------------------\n-- Data type renaming (this includes kind checking)\n\nrenameDataTypes\n :: (MonadSupply Int m, MonadThrow m)\n => Specials Name\n -> [DataType UnkindedType Identifier]\n -> m [DataType Type Name]\nrenameDataTypes specials types = do\n typeConstructors <-\n mapM\n (\\(DataType name vars cs) -> do\n name' <- supplyTypeName name\n vars' <-\n mapM\n (\\(TypeVariable i k) -> do\n i' <- supplyTypeName i\n pure (i, TypeVariable i' k))\n vars\n pure (name, name', vars', cs))\n types\n mapM\n (\\(_, name, vars, cs) -> do\n cs' <- mapM (renameConstructor specials typeConstructors vars) cs\n pure (DataType name (map snd vars) cs'))\n typeConstructors\n\nrenameConstructor\n :: (MonadSupply Int m, MonadThrow m)\n => Specials Name -> [(Identifier, Name, [(Identifier, TypeVariable Name)], [DataTypeConstructor UnkindedType Identifier])]\n -> [(Identifier, TypeVariable Name)]\n -> DataTypeConstructor UnkindedType Identifier\n -> m (DataTypeConstructor Type Name)\nrenameConstructor specials typeConstructors vars (DataTypeConstructor name fields) = do\n name' <- supplyConstructorName name\n fields' <- mapM (renameField specials typeConstructors vars name') fields\n pure (DataTypeConstructor name' fields')\n\nrenameField\n :: (MonadThrow m, MonadSupply Int m)\n => Specials Name\n -> [(Identifier, Name, [(Identifier, TypeVariable Name)], [DataTypeConstructor UnkindedType Identifier])]\n -> [(Identifier, TypeVariable Name)]\n -> Name\n -> UnkindedType Identifier\n -> m (Type Name)\nrenameField specials typeConstructors vars name fe = do\n ty <- go fe\n if typeKind ty == StarKind\n then pure ty\n else throwM (ConstructorFieldKind name ty (typeKind ty))\n where\n go =\n \\case\n UnkindedTypeConstructor i -> do\n (name', vars') <- resolve i\n pure (ConstructorType (toTypeConstructor name' (map snd vars')))\n UnkindedTypeVariable v ->\n case lookup v vars of\n Nothing -> throwM (UnknownTypeVariable (map snd vars) v)\n Just tyvar -> pure (VariableType tyvar)\n UnkindedTypeApp f x -> do\n f' <- go f\n let fKind = typeKind f'\n case fKind of\n FunctionKind argKind _ -> do\n x' <- go x\n let xKind = typeKind x'\n if xKind == argKind\n then pure (ApplicationType f' x')\n else throwM (KindArgMismatch f' fKind x' xKind)\n StarKind -> do\n x' <- go x\n throwM (KindTooManyArgs f' fKind x')\n resolve i =\n case find ((\\(j, _, _, _) -> j == i)) typeConstructors of\n Just (_, name', vs, _) -> pure (name', vs)\n Nothing ->\n case specialTypesFunction (specialsTypes specials) of\n TypeConstructor n@(TypeName _ i') _\n | Identifier i' == i -> do\n fvars <-\n mapM\n (\\vari ->\n (vari, ) <$>\n fmap\n (\\varn -> TypeVariable varn StarKind)\n (supplyTypeVariableName vari))\n (map Identifier [\"a\", \"b\"])\n pure (n, fvars)\n _ ->\n case listToMaybe (mapMaybe (matches i) builtinStarTypes) of\n Just ty -> pure ty\n Nothing ->\n case find\n (\\case\n TypeName _ tyi -> Identifier tyi == i\n _ -> False)\n (map\n typeConstructorIdentifier\n [ specialTypesChar (specialsTypes specials)\n , specialTypesInteger (specialsTypes specials)\n , specialTypesRational (specialsTypes specials)\n , specialTypesString (specialsTypes specials)\n ]) of\n Just ty -> pure (ty, [])\n _ -> throwM (TypeNotInScope [] i)\n matches i t =\n case t of\n DataType n@(TypeName _ i') vs _\n | Identifier i' == i ->\n Just\n ( n\n , mapMaybe\n (\\case\n (TypeVariable n'@(TypeName _ tyi) k) ->\n Just (Identifier tyi, TypeVariable n' k)\n _ -> Nothing)\n vs)\n _ -> Nothing\n builtinStarTypes = [specialTypesBool (specialsTypes specials)]\n\n--------------------------------------------------------------------------------\n-- Class renaming\n\nrenameClass\n :: forall m.\n (MonadSupply Int m, MonadThrow m)\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> Class UnkindedType Identifier Location\n -> m (Class Type Name Location)\nrenameClass specials subs types cls = do\n name <- supplyClassName (className cls)\n classVars <-\n mapM\n (\\(TypeVariable i k) -> do\n i' <- supplyTypeName i\n pure (i, TypeVariable i' k))\n (classTypeVariables cls)\n instances <-\n mapM\n (renameInstance' specials subs types classVars)\n (classInstances cls)\n methods' <-\n fmap\n M.fromList\n (mapM\n (\\(mname, (Forall vars (Qualified preds ty))) -> do\n name' <- supplyMethodName mname\n methodVars <- mapM (renameMethodTyVar classVars) vars\n let classAndMethodVars = nub (classVars ++ methodVars)\n ty' <- renameType specials classAndMethodVars types ty\n preds' <-\n mapM\n (\\(IsIn c tys) ->\n IsIn <$> substituteClass subs c <*>\n mapM (renameType specials classAndMethodVars types) tys)\n preds\n pure\n ( name'\n , (Forall (map snd classAndMethodVars) (Qualified preds' ty'))))\n (M.toList (classMethods cls)))\n pure\n (Class\n { className = name\n , classTypeVariables = map snd classVars\n , classSuperclasses = []\n , classInstances = instances\n , classMethods = methods'\n })\n where\n renameMethodTyVar\n :: [(Identifier, TypeVariable Name)]\n -> TypeVariable Identifier\n -> m (Identifier, TypeVariable Name)\n renameMethodTyVar classTable (TypeVariable ident k) =\n case lookup ident classTable of\n Nothing -> do\n i' <- supplyTypeName ident\n pure (ident, TypeVariable i' k)\n Just v -> pure (ident, v)\n\n--------------------------------------------------------------------------------\n-- Instance renaming\n\nrenameInstance\n :: (MonadThrow m, MonadSupply Int m)\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> [Class Type Name l]\n -> Instance UnkindedType Identifier Location\n -> m (Instance Type Name Location)\nrenameInstance specials subs types classes inst@(Instance (Forall _ (Qualified _ (IsIn className' _))) _) = do\n {-trace (\"renameInstance: Classes: \" ++ show (map className classes)) (return ())-}\n table <- mapM (\\c -> fmap (, c) (identifyClass (className c))) classes\n {-trace (\"renameInstance: Table: \" ++ show table) (return ())-}\n case lookup className' table of\n Nothing ->\n do {-trace (\"renameInstance: ???\" ++ show className') (return ())-}\n throwM\n (IdentifierNotInClassScope\n (M.fromList (map (second className) table))\n className')\n Just typeClass -> do\n vars <-\n mapM\n (\\v@(TypeVariable i _) -> fmap (, v) (identifyType i))\n (classTypeVariables typeClass)\n instr <- renameInstance' specials subs types vars inst\n pure instr\n\nrenameInstance'\n :: (MonadThrow m, MonadSupply Int m)\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> [(Identifier, TypeVariable Name)]\n -> Instance UnkindedType Identifier Location\n -> m (Instance Type Name Location)\nrenameInstance' specials subs types _tyVars (Instance (Forall vars (Qualified preds ty)) dict) = do\n let vars0 =\n nub\n (if null vars\n then concat\n (map\n collectTypeVariables\n (case ty of\n IsIn _ t -> t))\n else vars)\n vars'' <-\n mapM\n (\\(TypeVariable i k) -> do\n n <- supplyTypeName i\n pure (i, TypeVariable n k))\n vars0\n preds' <- mapM (renamePredicate specials subs vars'' types) preds\n ty' <- renamePredicate specials subs vars'' types ty\n dict' <- renameDict specials subs types dict ty'\n pure (Instance (Forall (map snd vars'') (Qualified preds' ty')) dict')\n where\n collectTypeVariables :: UnkindedType i -> [TypeVariable i]\n collectTypeVariables =\n \\case\n UnkindedTypeConstructor {} -> []\n UnkindedTypeVariable i -> [TypeVariable i StarKind]\n UnkindedTypeApp f x -> collectTypeVariables f ++ collectTypeVariables x\n\nrenameDict\n :: (MonadThrow m, MonadSupply Int m)\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> Dictionary UnkindedType Identifier Location\n -> Predicate Type Name\n -> m (Dictionary Type Name Location)\nrenameDict specials subs types (Dictionary _ methods) predicate = do\n name' <-\n supplyDictName'\n (Identifier (predicateToDict specials predicate))\n methods' <-\n fmap\n M.fromList\n (mapM\n (\\(n, (l, alt)) -> do\n n' <- supplyMethodName n\n alt' <- renameAlt specials subs types alt\n pure (n', (l, alt')))\n (M.toList methods))\n pure (Dictionary name' methods')\n\npredicateToDict :: Specials Name -> ((Predicate Type Name)) -> String\npredicateToDict specials p =\n \"$dict\" ++ map normalize (printPredicate defaultPrint (specialsTypes specials) p)\n where\n normalize c\n | isDigit c || isLetter c = c\n | otherwise = '_'\n\n\nrenamePredicate\n :: (MonadThrow m, Typish (t i), Identifiable i)\n => Specials Name\n -> Map Identifier Name\n -> [(Identifier, TypeVariable Name)]\n -> [DataType Type Name]\n -> Predicate t i\n -> m (Predicate Type Name)\nrenamePredicate specials subs tyVars types (IsIn className' types0) =\n do subbedClassName <- substituteClass subs className'\n types' <- mapM (renameType specials tyVars types -- >=> forceStarKind\n ) types0\n pure (IsIn subbedClassName types')\n\n-- | Force that the type has kind *.\n_forceStarKind :: MonadThrow m => Type Name -> m (Type Name)\n_forceStarKind ty =\n case typeKind ty of\n StarKind -> pure ty\n _ -> throwM (MustBeStarKind ty (typeKind ty))\n\nrenameScheme\n :: (MonadSupply Int m, MonadThrow m, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> Scheme t i t\n -> m (Scheme Type Name Type)\nrenameScheme specials subs types (Forall tyvars (Qualified ps ty)) = do\n tyvars' <-\n mapM\n (\\(TypeVariable i kind) -> do\n do n <-\n case nonrenamableName i of\n Just k -> pure k\n Nothing -> do\n i' <- identifyType i\n supplyTypeName i'\n ident <- identifyType n\n (ident, ) <$> (TypeVariable <$> pure n <*> pure kind))\n tyvars\n ps' <- mapM (renamePredicate specials subs tyvars' types) ps\n ty' <- renameType specials tyvars' types ty\n pure (Forall (map snd tyvars') (Qualified ps' ty'))\n\n-- | Rename a type, checking kinds, taking names, etc.\nrenameType\n :: (MonadThrow m, Typish (t i))\n => Specials Name\n -> [(Identifier, TypeVariable Name)]\n -> [DataType Type Name]\n -> t i\n -> m (Type Name)\nrenameType specials tyVars types t = either go pure (isType t)\n where\n go =\n \\case\n UnkindedTypeConstructor i -> do\n ms <- mapM (\\p -> fmap (, p) (identifyType (dataTypeName p))) types\n case lookup i ms of\n Nothing -> do\n do specials'' <- sequence specials'\n case lookup i specials'' of\n Nothing ->\n throwM\n (TypeNotInScope\n (map dataTypeToConstructor (map snd ms))\n i)\n Just t' -> pure (ConstructorType t')\n Just dty -> pure (dataTypeConstructor dty)\n UnkindedTypeVariable i -> do\n case lookup i tyVars of\n Nothing -> throwM (UnknownTypeVariable (map snd tyVars) i)\n Just ty -> do\n pure (VariableType ty)\n UnkindedTypeApp f a -> do\n f' <- go f\n case typeKind f' of\n FunctionKind argKind _ -> do\n a' <- go a\n if typeKind a' == argKind\n then pure (ApplicationType f' a')\n else throwM (KindArgMismatch f' (typeKind f') a' (typeKind a'))\n StarKind -> do\n a' <- go a\n throwM (KindTooManyArgs f' (typeKind f') a')\n specials' =\n [ setup (specialTypesFunction . specialsTypes)\n , setup (specialTypesInteger . specialsTypes)\n , setup (specialTypesChar . specialsTypes)\n , setup (specialTypesRational . specialsTypes)\n , setup (specialTypesString . specialsTypes)\n , setup (dataTypeToConstructor . specialTypesBool . specialsTypes)\n ]\n where\n setup f = do\n i <- identifyType (typeConstructorIdentifier (f specials))\n pure (i, f specials)\n\n--------------------------------------------------------------------------------\n-- Value renaming\n\nrenameBindGroups\n :: ( MonadSupply Int m\n , MonadThrow m\n , Ord i\n , Identifiable i\n , Typish (UnkindedType i)\n )\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> [BindGroup UnkindedType i Location]\n -> m ([BindGroup Type Name Location], Map Identifier Name)\nrenameBindGroups specials subs types groups = do\n subs' <-\n fmap\n mconcat\n (mapM\n (\\(BindGroup explicit implicit) -> do\n implicit' <- getImplicitSubs subs implicit\n explicit' <- getExplicitSubs subs explicit\n pure (explicit' <> implicit'))\n groups)\n fmap\n (second mconcat . unzip)\n (mapM (renameBindGroup specials subs' types) groups)\n\nrenameBindings\n :: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> [Binding t i Location]\n -> m ([Binding Type Name Location], Map Identifier Name)\nrenameBindings specials subs types bindings = do\n subs' <-\n fmap\n ((<> subs) . M.fromList)\n (mapM\n (\\case\n ExplicitBinding (ExplicitlyTypedBinding _ (i, _) _ _) -> do\n v <- identifyValue i\n fmap (v, ) (supplyValueName i)\n ImplicitBinding (ImplicitlyTypedBinding _ (i, _) _) -> do\n v <- identifyValue i\n fmap (v, ) (supplyValueName i))\n bindings)\n bindings' <-\n mapM\n (\\case\n ExplicitBinding e ->\n ExplicitBinding <$> renameExplicit specials subs' types e\n ImplicitBinding i ->\n ImplicitBinding <$> renameImplicit specials subs' types i)\n bindings\n pure (bindings', subs')\n\nrenameBindGroup\n :: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> BindGroup t i Location\n -> m (BindGroup Type Name Location, Map Identifier Name)\nrenameBindGroup specials subs types (BindGroup explicit implicit) = do\n bindGroup' <-\n BindGroup <$> mapM (renameExplicit specials subs types) explicit <*>\n mapM (mapM (renameImplicit specials subs types)) implicit\n pure (bindGroup', subs)\n\ngetImplicitSubs\n :: (MonadSupply Int m, Identifiable i, MonadThrow m)\n => Map Identifier Name\n -> [[ImplicitlyTypedBinding t i l]]\n -> m (Map Identifier Name)\ngetImplicitSubs subs implicit =\n fmap\n ((<> subs) . M.fromList)\n (mapM\n (\\(ImplicitlyTypedBinding _ (i, _) _) -> do\n v <- identifyValue i\n fmap (v, ) (supplyValueName i))\n (concat implicit))\n\ngetExplicitSubs\n :: (MonadSupply Int m, Identifiable i, MonadThrow m)\n => Map Identifier Name\n -> [ExplicitlyTypedBinding t i l]\n -> m (Map Identifier Name)\ngetExplicitSubs subs explicit =\n fmap\n ((<> subs) . M.fromList)\n (mapM\n (\\(ExplicitlyTypedBinding _ (i, _) _ _) -> do\n v <- identifyValue i\n fmap (v, ) (supplyValueName i))\n explicit)\n\nrenameExplicit\n :: (MonadSupply Int m, MonadThrow m, Identifiable i, Ord i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> ExplicitlyTypedBinding t i Location\n -> m (ExplicitlyTypedBinding Type Name Location)\nrenameExplicit specials subs types (ExplicitlyTypedBinding l (i, l') scheme alts) = do\n name <- substituteVar subs i l'\n ExplicitlyTypedBinding l (name, l') <$> renameScheme specials subs types scheme <*>\n mapM (renameAlt specials subs types) alts\n\nrenameImplicit\n :: (MonadThrow m,MonadSupply Int m,Ord i, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> ImplicitlyTypedBinding t i Location\n -> m (ImplicitlyTypedBinding Type Name Location)\nrenameImplicit specials subs types (ImplicitlyTypedBinding l (id',l') alts) =\n do name <- substituteVar subs id' l'\n ImplicitlyTypedBinding l (name, l') <$> mapM (renameAlt specials subs types) alts\n\nrenameAlt ::\n (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> Alternative t i Location\n -> m (Alternative Type Name Location)\nrenameAlt specials subs types (Alternative l ps e) =\n do (ps', subs') <- runWriterT (mapM (renamePattern subs) ps)\n let subs'' = M.fromList subs' <> subs\n Alternative l <$> pure ps' <*> renameExpression specials subs'' types e\n\nrenamePattern\n :: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i)\n => Map Identifier Name\n -> Pattern t i l\n -> WriterT [(Identifier, Name)] m (Pattern Type Name l)\nrenamePattern subs =\n \\case\n BangPattern p -> fmap BangPattern (renamePattern subs p)\n VariablePattern l i -> do\n name <- maybe (lift (supplyValueName i)) pure (nonrenamableName i)\n v <- identifyValue i\n tell [(v, name)]\n pure (VariablePattern l name)\n WildcardPattern l s -> pure (WildcardPattern l s)\n AsPattern l i p -> do\n name <- supplyValueName i\n v <- identifyValue i\n tell [(v, name)]\n AsPattern l name <$> renamePattern subs p\n LiteralPattern l0 l -> pure (LiteralPattern l0 l)\n ConstructorPattern l i pats ->\n ConstructorPattern l <$> substituteCons subs i <*>\n mapM (renamePattern subs) pats\n\nclass Typish t where isType :: t -> Either (UnkindedType Identifier) (Type Name)\ninstance Typish (Type Name) where isType = Right\ninstance Typish (UnkindedType Identifier) where isType = Left\n\nrenameExpression\n :: forall t i m.\n (MonadThrow m, MonadSupply Int m, Ord i, Identifiable i, Typish (t i))\n => Specials Name\n -> Map Identifier Name\n -> [DataType Type Name]\n -> Expression t i Location\n -> m (Expression Type Name Location)\nrenameExpression specials subs types = go\n where\n go :: Expression t i Location -> m (Expression Type Name Location)\n go =\n \\case\n ParensExpression l e -> ParensExpression l <$> go e\n VariableExpression l i -> VariableExpression l <$> substituteVar subs i l\n ConstructorExpression l i ->\n ConstructorExpression l <$> substituteCons subs i\n ConstantExpression l i -> pure (ConstantExpression l i)\n LiteralExpression l i -> pure (LiteralExpression l i)\n ApplicationExpression l f x -> ApplicationExpression l <$> go f <*> go x\n InfixExpression l x (orig, VariableExpression l0 i) y -> do\n i' <-\n case nonrenamableName i of\n Just nr -> pure nr\n Nothing -> do\n ident <- identifyValue i\n case lookup ident operatorTable of\n Just f -> pure (f (specialsSigs specials))\n _ -> throwM (IdentifierNotInVarScope subs ident l0)\n InfixExpression l <$> go x <*> pure (orig, VariableExpression l0 i') <*>\n go y\n InfixExpression l x (orig, o) y ->\n InfixExpression l <$> go x <*> fmap (orig,) (go o) <*> go y\n LetExpression l bindGroup@(BindGroup ex implicit) e -> do\n subs0 <- getImplicitSubs subs implicit\n subs1 <- getExplicitSubs subs ex\n (bindGroup', subs'') <-\n renameBindGroup specials (subs0 <> subs1) types bindGroup\n LetExpression l <$> pure bindGroup' <*>\n renameExpression specials subs'' types e\n LambdaExpression l alt ->\n LambdaExpression l <$> renameAlt specials subs types alt\n IfExpression l x y z -> IfExpression l <$> go x <*> go y <*> go z\n CaseExpression l e pat_exps ->\n CaseExpression l <$> go e <*>\n mapM\n (\\(CaseAlt l1 pat ex) -> do\n (pat', subs') <- runWriterT (renamePattern subs pat)\n e' <-\n renameExpression specials (M.fromList subs' <> subs) types ex\n pure (CaseAlt l1 pat' e'))\n pat_exps\n\n--------------------------------------------------------------------------------\n-- Provide a substitution\n\nsubstituteVar :: (Identifiable i, MonadThrow m) => Map Identifier Name -> i -> Location -> m Name\nsubstituteVar subs i0 l =\n case nonrenamableName i0 of\n Nothing -> do\n i <- identifyValue i0\n case M.lookup i subs of\n Just name@ValueName {} -> pure name\n Just name@MethodName {} -> pure name\n Just name@DictName {} -> pure name\n _ -> do\n s <- identifyValue i\n throwM (IdentifierNotInVarScope subs s l)\n Just n -> pure n\n\nsubstituteClass :: (Identifiable i, MonadThrow m) => Map Identifier Name -> i -> m Name\nsubstituteClass subs i0 =\n do i <- identifyValue i0\n case M.lookup i subs of\n Just name@ClassName{} -> pure name\n _ -> do s <- identifyValue i\n throwM (IdentifierNotInClassScope subs s)\n\nsubstituteCons :: (Identifiable i, MonadThrow m) => Map Identifier Name -> i -> m Name\nsubstituteCons subs i0 =\n do i <- identifyValue i0\n case M.lookup i subs of\n Just name@ConstructorName{} -> pure name\n _ -> do throwM (IdentifierNotInConScope subs i)\n\noperatorTable :: [(Identifier, SpecialSigs i -> i)]\noperatorTable =\n map\n (first Identifier)\n [ (\"+\", specialSigsPlus)\n , (\"-\", specialSigsSubtract)\n , (\"*\", specialSigsTimes)\n , (\"/\", specialSigsDivide)\n ]\n"
},
{
"path": "src/Duet/Resolver.hs",
"content": "{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE Strict #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE NoMonomorphismRestriction #-}\n\n-- | Resolve type-class instances.\n\nmodule Duet.Resolver where\n\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport Data.List\nimport Data.Map.Strict (Map)\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Duet.Infer\nimport Duet.Printer\nimport Duet.Supply\nimport Duet.Types\n\nresolveTypeClasses\n :: (MonadSupply Int f, MonadThrow f)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> f (Map Name (Class Type Name (TypeSignature Type Name l)))\nresolveTypeClasses typeClasses specialTypes = go typeClasses\n where\n go =\n fmap M.fromList .\n mapM\n (\\(name, cls) -> do\n is <-\n mapM\n (\\inst -> do\n ms <-\n mapM\n (\\(nam, (l, alt)) ->\n fmap ((nam, ) . (l, )) (resolveAlt typeClasses specialTypes alt))\n (M.toList (dictionaryMethods (instanceDictionary inst)))\n pure\n inst\n { instanceDictionary =\n (instanceDictionary inst)\n {dictionaryMethods = M.fromList ms}\n })\n (classInstances cls)\n pure (name, cls {classInstances = is})) .\n M.toList\n\nresolveBindGroup\n :: (MonadSupply Int m, MonadThrow m)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> BindGroup Type Name (TypeSignature Type Name l)\n -> m (BindGroup Type Name (TypeSignature Type Name l))\nresolveBindGroup classes specialTypes (BindGroup explicit implicit) = do\n explicits <- mapM (resolveExplicit classes specialTypes) explicit\n implicits <- mapM (mapM (resolveImplicit classes specialTypes)) implicit\n pure (BindGroup explicits implicits)\n\nresolveImplicit\n :: (MonadSupply Int m, MonadThrow m)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> ImplicitlyTypedBinding Type Name (TypeSignature Type Name l)\n -> m (ImplicitlyTypedBinding Type Name (TypeSignature Type Name l))\nresolveImplicit classes specialTypes (ImplicitlyTypedBinding l name alts) =\n ImplicitlyTypedBinding l name <$> mapM (resolveAlt classes specialTypes) alts\n\nresolveExplicit\n :: (MonadSupply Int m, MonadThrow m)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> ExplicitlyTypedBinding Type Name (TypeSignature Type Name l)\n -> m (ExplicitlyTypedBinding Type Name (TypeSignature Type Name l))\nresolveExplicit classes specialTypes (ExplicitlyTypedBinding l scheme name alts) =\n ExplicitlyTypedBinding l scheme name <$> mapM (resolveAlt classes specialTypes) alts\n\nresolveAlt\n :: (MonadSupply Int m, MonadThrow m)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> Alternative Type Name (TypeSignature Type Name l)\n -> m (Alternative Type Name (TypeSignature Type Name l))\nresolveAlt classes specialTypes (Alternative l ps e) = do\n dicts <-\n mapM\n (\\pred' ->\n (pred', ) <$> supplyDictName (predicateToString specialTypes pred'))\n (filter (\\p -> (not (isJust (byInst classes p)))) (nub predicates))\n (Alternative l <$> pure ps <*>\n resolveExp\n classes\n specialTypes\n dicts\n (if null dicts\n then e\n else let dictArgs = [VariablePattern l d | (_, d) <- dicts]\n in case e of\n LambdaExpression _ (Alternative l0 args e0) ->\n LambdaExpression l (Alternative l0 (dictArgs ++ args) e0)\n _ -> LambdaExpression l (Alternative l dictArgs e)))\n where\n Forall _ (Qualified predicates _) = typeSignatureScheme l\n\npredicateToString\n :: (Printable i)\n => SpecialTypes i -> Predicate Type i -> String\npredicateToString _specialTypes (IsIn name _ts) =\n -- printIdentifier name ++ \" \" ++ unwords (map (printType specialTypes) ts)\n \"?dict\" ++ printIdentifier defaultPrint name\n\nresolveExp\n :: (MonadThrow m)\n => Map Name (Class Type Name (TypeSignature Type Name l))\n -> SpecialTypes Name\n -> [(Predicate Type Name, Name)]\n -> Expression Type Name (TypeSignature Type Name l)\n -> m (Expression Type Name (TypeSignature Type Name l))\nresolveExp classes _ dicts = go\n where\n go =\n \\case\n ParensExpression l e -> ParensExpression l <$> go e\n VariableExpression l i -> do\n dictArgs <- fmap concat (mapM (lookupDictionary l) predicates)\n pure\n (foldl (ApplicationExpression l) (VariableExpression l i) dictArgs)\n where Forall _ (Qualified predicates _) = typeSignatureScheme l\n ApplicationExpression l f x -> ApplicationExpression l <$> go f <*> go x\n InfixExpression l x (i, op) y ->\n InfixExpression l <$> go x <*> fmap (i, ) (go op) <*> go y\n LambdaExpression l0 (Alternative l vs b) ->\n LambdaExpression l0 <$> (Alternative l vs <$> go b)\n CaseExpression l e alts ->\n CaseExpression l <$> go e <*>\n mapM (\\(CaseAlt l' p e') -> fmap (CaseAlt l' p) (go e')) alts\n e@ConstructorExpression {} -> pure e\n e@ConstantExpression {} -> pure e\n IfExpression l a b c -> IfExpression l <$> go a <*> go b <*> go c\n e@LiteralExpression {} -> pure e\n LetExpression {} -> error \"Let expressions not supported.\"\n lookupDictionary l p =\n (case byInst classes p of\n Just (preds, dict) -> do\n do parents <- fmap concat (mapM (lookupDictionary l) preds)\n pure (VariableExpression l (dictionaryName dict) : parents)\n Nothing ->\n case lookup p dicts of\n Nothing -> throwM (NoInstanceFor p)\n Just v -> pure [VariableExpression l v])\n"
},
{
"path": "src/Duet/Setup.hs",
"content": "{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- | Shared application code between commandline and web interface.\n\nmodule Duet.Setup where\n\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport Data.Map.Strict (Map)\nimport Duet.Context\nimport Duet.Infer\nimport Duet.Renamer\nimport Duet.Supply\nimport Duet.Types\n\n--------------------------------------------------------------------------------\n-- Setting the context\n\n-- | Setup the class environment.\nsetupEnv\n :: (MonadThrow m, MonadSupply Int m)\n => Map Name (Class Type Name ())\n -> [SpecialTypes Name -> m (DataType Type Name)]\n -> m (Builtins Type Name ())\nsetupEnv env typeMakers = do\n theArrow <- supplyTypeName \"(->)\"\n theChar <- supplyTypeName \"Char\"\n theString <- supplyTypeName \"String\"\n theInteger <- supplyTypeName \"Integer\"\n theRational <- supplyTypeName \"Rational\"\n (true, false, boolDataType) <-\n do name <- supplyTypeName \"Bool\"\n true <- supplyConstructorName \"True\"\n false <- supplyConstructorName \"False\"\n pure\n ( true\n , false\n , DataType\n name\n []\n [DataTypeConstructor true [], DataTypeConstructor false []])\n let function =\n (TypeConstructor\n theArrow\n (FunctionKind StarKind (FunctionKind StarKind StarKind)))\n let specialTypes =\n (SpecialTypes\n { specialTypesBool = boolDataType\n , specialTypesChar = TypeConstructor theChar StarKind\n , specialTypesString = TypeConstructor theString StarKind\n , specialTypesFunction = function\n , specialTypesInteger = TypeConstructor theInteger StarKind\n , specialTypesRational = TypeConstructor theRational StarKind\n })\n (numClass, plus, times) <- makeNumClass function\n (negClass, subtract') <- makeNegClass function\n (fracClass, divide) <- makeFracClass function\n (monoidClass) <- makeMonoidClass function\n (sliceClass) <- makeSliceClass (specialTypesInteger specialTypes) function\n boolSigs <- dataTypeSignatures specialTypes boolDataType\n typesSigs <-\n fmap\n concat\n (mapM ($ specialTypes) typeMakers >>=\n mapM (dataTypeSignatures specialTypes))\n classSigs <-\n fmap\n concat\n (mapM classSignatures [numClass, negClass, fracClass, monoidClass, sliceClass])\n primopSigs <- makePrimOps specialTypes\n let signatures = boolSigs <> classSigs <> primopSigs <> typesSigs\n specialSigs =\n SpecialSigs\n { specialSigsTrue = true\n , specialSigsFalse = false\n , specialSigsPlus = plus\n , specialSigsSubtract = subtract'\n , specialSigsTimes = times\n , specialSigsDivide = divide\n }\n specials = Specials specialSigs specialTypes\n stringSlice <-\n makeInst\n specials\n (IsIn\n (className sliceClass)\n [ConstructorType (specialTypesString specialTypes)])\n [ ( \"take\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopStringTake))))\n , ( \"drop\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopStringDrop))))\n ]\n stringMonoid <-\n makeInst\n specials\n (IsIn\n (className monoidClass)\n [ConstructorType (specialTypesString specialTypes)])\n [ ( \"append\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopStringAppend))))\n , ( \"empty\"\n , ((), Alternative () [] (LiteralExpression () (StringLiteral \"\"))))\n ]\n numInt <-\n makeInst\n specials\n (IsIn\n (className numClass)\n [ConstructorType (specialTypesInteger specialTypes)])\n [ ( \"times\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopIntegerTimes))))\n , ( \"plus\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopIntegerPlus))))\n ]\n negInt <-\n makeInst\n specials\n (IsIn\n (className negClass)\n [ConstructorType (specialTypesInteger specialTypes)])\n [ ( \"subtract\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopIntegerSubtract))))\n ]\n numRational <-\n makeInst\n specials\n (IsIn\n (className numClass)\n [ConstructorType (specialTypesRational specialTypes)])\n [ ( \"times\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopRationalTimes))))\n , ( \"plus\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopRationalPlus))))\n ]\n negRational <-\n makeInst\n specials\n (IsIn\n (className negClass)\n [ConstructorType (specialTypesRational specialTypes)])\n [ ( \"subtract\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopRationalSubtract))))\n ]\n fracRational <-\n makeInst\n specials\n (IsIn\n (className fracClass)\n [ConstructorType (specialTypesRational specialTypes)])\n [ ( \"divide\"\n , ( ()\n , Alternative\n ()\n []\n (VariableExpression () (PrimopName PrimopRationalDivide))))\n ]\n env' <-\n let update =\n addClass numClass >=>\n addClass negClass >=>\n addClass fracClass >=>\n addClass monoidClass >=>\n addClass sliceClass >=>\n addInstance numInt >=>\n addInstance negInt >=>\n addInstance stringMonoid >=>\n addInstance stringSlice >=>\n addInstance fracRational >=>\n addInstance negRational >=> addInstance numRational\n in update env\n pure\n Builtins\n { builtinsSpecialSigs = specialSigs\n , builtinsSpecialTypes = specialTypes\n , builtinsSignatures = signatures\n , builtinsTypeClasses = env'\n }\n\n--------------------------------------------------------------------------------\n-- Builtin classes and primops\n\nmakePrimOps\n :: (MonadSupply Int m)\n => SpecialTypes Name -> m [TypeSignature Type Name Name]\nmakePrimOps SpecialTypes {..} = do\n let sigs =\n map\n ((\\case\n PrimopIntegerPlus ->\n TypeSignature\n (PrimopName PrimopIntegerPlus)\n (toScheme (integer --> integer --> integer))\n PrimopIntegerSubtract ->\n TypeSignature\n (PrimopName PrimopIntegerSubtract)\n (toScheme (integer --> integer --> integer))\n PrimopIntegerTimes ->\n TypeSignature\n (PrimopName PrimopIntegerTimes)\n (toScheme (integer --> integer --> integer))\n PrimopRationalDivide ->\n TypeSignature\n (PrimopName PrimopRationalDivide)\n (toScheme (rational --> rational --> rational))\n PrimopRationalPlus ->\n TypeSignature\n (PrimopName PrimopRationalPlus)\n (toScheme (rational --> rational --> rational))\n PrimopRationalSubtract ->\n TypeSignature\n (PrimopName PrimopRationalSubtract)\n (toScheme (rational --> rational --> rational))\n PrimopRationalTimes ->\n TypeSignature\n (PrimopName PrimopRationalTimes)\n (toScheme (rational --> rational --> rational))\n PrimopStringAppend ->\n TypeSignature\n (PrimopName PrimopStringAppend)\n (toScheme (string --> string --> string))\n PrimopStringTake ->\n TypeSignature\n (PrimopName PrimopStringTake)\n (toScheme (integer --> string --> string))\n PrimopStringDrop ->\n TypeSignature\n (PrimopName PrimopStringDrop)\n (toScheme (integer --> string --> string))))\n [minBound .. maxBound]\n pure sigs\n where\n integer = ConstructorType specialTypesInteger\n rational = ConstructorType specialTypesRational\n string = ConstructorType specialTypesString\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b =\n ApplicationType\n (ApplicationType (ConstructorType specialTypesFunction) a)\n b\n\nmakeNumClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name, Name)\nmakeNumClass function = do\n a <- fmap (\\n -> TypeVariable n StarKind) (supplyTypeName \"a\")\n let a' = VariableType a\n plus <- supplyMethodName \"plus\"\n times <- supplyMethodName \"times\"\n cls <-\n makeClass\n \"Num\"\n [a]\n [ (plus, Forall [a] (Qualified [] (a' --> a' --> a')))\n , (times, Forall [a] (Qualified [] (a' --> a' --> a')))\n ]\n pure (cls, plus, times)\n where\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b\n\nmakeNegClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name)\nmakeNegClass function = do\n a <- fmap (\\n -> TypeVariable n StarKind) (supplyTypeName \"a\")\n let a' = VariableType a\n negate' <- supplyMethodName \"negate\"\n subtract' <- supplyMethodName \"subtract\"\n abs' <- supplyMethodName \"abs\"\n cls <-\n makeClass\n \"Neg\"\n [a]\n [ (negate', Forall [a] (Qualified [] (a' --> a' --> a')))\n , (subtract', Forall [a] (Qualified [] (a' --> a' --> a')))\n , (abs', Forall [a] (Qualified [] (a' --> a')))\n ]\n pure (cls, subtract')\n where\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b\n\nmakeFracClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name)\nmakeFracClass function = do\n a <- fmap (\\n -> TypeVariable n StarKind) (supplyTypeName \"a\")\n let a' = VariableType a\n divide <- supplyMethodName \"divide\"\n recip' <- supplyMethodName \"recip\"\n cls <-\n makeClass\n \"Fractional\"\n [a]\n [ (divide, Forall [a] (Qualified [] (a' --> a' --> a')))\n , (recip', Forall [a] (Qualified [] (a' --> a')))\n ]\n pure (cls, divide)\n where\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b\n\nmakeMonoidClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l)\nmakeMonoidClass function = do\n a <- fmap (\\n -> TypeVariable n StarKind) (supplyTypeName \"a\")\n let a' = VariableType a\n append <- supplyMethodName \"append\"\n empty <- supplyMethodName \"empty\"\n cls <-\n makeClass\n \"Monoid\"\n [a]\n [ (append, Forall [a] (Qualified [] (a' --> a' --> a')))\n , (empty, Forall [a] (Qualified [] (a')))\n ]\n pure cls\n where\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b\n\nmakeSliceClass :: MonadSupply Int m => TypeConstructor Name -> TypeConstructor Name -> m (Class Type Name l)\nmakeSliceClass integer' function = do\n a <- fmap (\\n -> TypeVariable n StarKind) (supplyTypeName \"a\")\n let a' = VariableType a\n drop' <- supplyMethodName \"drop\"\n take' <- supplyMethodName \"take\"\n cls <-\n makeClass\n \"Slice\"\n [a]\n [ (drop', Forall [a] (Qualified [] (ConstructorType integer' --> (a' --> a'))))\n , (take', Forall [a] (Qualified [] (ConstructorType integer' --> (a' --> a'))))\n ]\n pure cls\n where\n infixr 1 -->\n (-->) :: Type Name -> Type Name -> Type Name\n a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b\n"
},
{
"path": "src/Duet/Simple.hs",
"content": "{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- |\n\nmodule Duet.Simple where\n\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport Control.Monad.Writer\nimport Duet.Context\nimport Duet.Infer\nimport Duet.Printer\nimport Duet.Renamer\nimport Duet.Resolver\nimport Duet.Setup\nimport Duet.Stepper\nimport Duet.Types\n\n-- | Create a context of all renamed, checked and resolved code.\ncreateContext\n :: (MonadSupply Int m, MonadCatch m)\n => [Decl UnkindedType Identifier Location]\n -> m ([BindGroup Type Name (TypeSignature Type Name Location)], Context Type Name Location)\ncreateContext decls = do\n do builtins <-\n setupEnv mempty [] >>=\n traverse\n (const\n (pure\n (Location\n { locationStartLine = 0\n , locationStartColumn = 0\n , locationEndLine = 0\n , locationEndColumn = 0\n })))\n let specials = builtinsSpecials builtins\n catch\n (do (typeClasses, signatures, renamedBindings, scope, dataTypes) <-\n renameEverything decls specials builtins\n -- Type class definition\n addedTypeClasses <- addClasses builtins typeClasses\n -- Type checking\n (bindGroups, typeCheckedClasses) <-\n typeCheckModule\n addedTypeClasses\n signatures\n (builtinsSpecialTypes builtins)\n renamedBindings\n -- Type class resolution\n resolvedTypeClasses <-\n resolveTypeClasses\n typeCheckedClasses\n (builtinsSpecialTypes builtins)\n resolvedBindGroups <-\n mapM\n (resolveBindGroup\n resolvedTypeClasses\n (builtinsSpecialTypes builtins))\n bindGroups\n -- Create a context of everything\n let ctx =\n Context\n { contextSpecialSigs = builtinsSpecialSigs builtins\n , contextSpecialTypes = builtinsSpecialTypes builtins\n , contextSignatures = signatures\n , contextScope = scope\n , contextTypeClasses = resolvedTypeClasses\n , contextDataTypes = dataTypes\n }\n pure (resolvedBindGroups, ctx))\n (throwM . ContextException (builtinsSpecialTypes builtins))\n\n-- | Run the substitution model on the code.\nrunStepper\n :: forall m. (MonadWriter [Expression Type Name ()] m, MonadSupply Int m, MonadThrow m)\n => Int\n -> Context Type Name Location\n -> [BindGroup Type Name Location]\n -> String\n -> m ()\nrunStepper maxSteps ctx bindGroups' i = do\n e0 <- lookupNameByString i bindGroups'\n loop 1 \"\" e0\n where\n loop ::\n Int\n -> String\n -> Expression Type Name Location\n -> m ()\n loop count lastString e = do\n e' <- expandSeq1 ctx bindGroups' e\n let string = printExpression (defaultPrint) e\n when (string /= lastString) (tell [fmap (const ()) e])\n if (fmap (const ()) e' /= fmap (const ()) e) && count < maxSteps\n then do\n newE <-\n renameExpression\n (contextSpecials ctx)\n (contextScope ctx)\n (contextDataTypes ctx)\n e'\n loop (count + 1) string newE\n else pure ()\n"
},
{
"path": "src/Duet/Stepper.hs",
"content": "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE Strict #-}\n{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- | The substitution stepper.\n\nmodule Duet.Stepper\n ( expandSeq1\n , fargs\n , lookupNameByString\n ) where\n\nimport Control.Applicative\nimport Control.Monad.Catch\nimport Control.Monad.State\nimport Data.List\nimport Data.Map.Strict (Map)\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Duet.Types\n\n--------------------------------------------------------------------------------\n-- Expansion\n\nexpandSeq1\n :: (MonadThrow m)\n => Context Type Name (Location)\n -> [BindGroup Type Name (Location)]\n -> Expression Type Name (Location)\n -> m (Expression Type Name (Location))\nexpandSeq1 (Context { contextTypeClasses = typeClassEnv\n , contextSpecialSigs = specialSigs\n , contextSignatures = signatures\n }) b e = evalStateT (go e) False\n where\n go =\n \\case\n e0\n -- If we're looking at a constructor, then force the args.\n | (ce@(ConstructorExpression l _), args) <- fargs e0 -> do\n args' <- mapM go args\n pure (foldl (ApplicationExpression l) ce args')\n -- If we're looking at a constant (hole), then force the args.\n | (ce@(ConstantExpression l _), args) <- fargs e0 -> do\n args' <- mapM go args\n pure (foldl (ApplicationExpression l) ce args')\n -- We're looking at a general expression, check if a force\n -- has already happpened. If so, we just return the\n -- identity.\n | otherwise -> do\n alreadyExpanded <- get\n if alreadyExpanded\n then pure e0\n else do\n -- If we haven't expanded anything yet, let's expand\n -- this mother to whnf.\n e' <- lift (expandWhnf typeClassEnv specialSigs signatures e0 b)\n -- If the expansion did actually produce a new AST\n -- then count that as an expansion.\n put (e' /= e0)\n pure e'\n\nexpandWhnf\n :: MonadThrow m\n => Map Name (Class Type Name (TypeSignature Type Name Location))\n -> SpecialSigs Name\n -> [TypeSignature Type Name Name]\n -> Expression Type Name (Location)\n -> [BindGroup Type Name (Location)]\n -> m (Expression Type Name (Location))\nexpandWhnf typeClassEnv specialSigs signatures e b = go e\n where\n go x =\n case x of\n -- Parens aren't an expansion step, just a grouping.\n ParensExpression _ e -> go e\n VariableExpression _ i -> do\n case find ((== i) . typeSignatureA) signatures of\n Nothing -> do\n e' <- lookupName i b\n pure e'\n Just {} -> pure x\n LiteralExpression {} -> return x\n ConstructorExpression {} -> return x\n ConstantExpression {} -> return x\n ApplicationExpression l (ApplicationExpression l1 op@(VariableExpression _ (PrimopName primop)) x) y ->\n case x of\n LiteralExpression _ (StringLiteral sx) ->\n case y of\n LiteralExpression _ (StringLiteral sy) ->\n case primop of\n PrimopStringAppend ->\n pure (LiteralExpression l (StringLiteral (sx <> sy)))\n _ -> error \"Runtime type error that should not occurr\"\n _ -> do\n y' <- go y\n pure\n (ApplicationExpression l (ApplicationExpression l1 op x) y')\n LiteralExpression _ (IntegerLiteral n) ->\n case y of\n LiteralExpression _ (StringLiteral sy) ->\n case primop of\n PrimopStringTake ->\n pure (LiteralExpression l (StringLiteral (genericTake n sy)))\n PrimopStringDrop ->\n pure (LiteralExpression l (StringLiteral (genericDrop n sy)))\n _ -> error \"Runtime type error that should not occurr\"\n _ -> do\n y' <- go y\n pure\n (ApplicationExpression l (ApplicationExpression l1 op x) y')\n _ -> do\n x' <- go x\n pure (ApplicationExpression l (ApplicationExpression l1 op x') y)\n ApplicationExpression l func arg ->\n case func of\n LambdaExpression l0 (Alternative l' params body) ->\n case params of\n (VariablePattern _ param:params') ->\n let body' = substitute param arg body\n in case params' of\n [] -> pure body'\n _ ->\n pure\n (LambdaExpression l0 (Alternative l' params' body'))\n _ -> error \"Unsupported lambda.\"\n VariableExpression _ (MethodName _ methodName) ->\n case arg of\n VariableExpression _ dictName@DictName {} ->\n case find\n ((== dictName) . dictionaryName)\n (concatMap\n (map instanceDictionary . classInstances)\n (M.elems typeClassEnv)) of\n Nothing -> throwM (CouldntFindMethodDict dictName)\n Just dict ->\n case M.lookup\n methodName\n (M.mapKeys\n (\\(MethodName _ s) -> s)\n (dictionaryMethods dict)) of\n Nothing ->\n error\n (\"Missing method \" ++\n show methodName ++ \" in dictionary: \" ++ show dict)\n Just (_, Alternative _ _ e) -> pure (fmap typeSignatureA e)\n _ -> error \"Unsupported variable expression.\"\n _ -> do\n func' <- go func\n pure (ApplicationExpression l func' arg)\n orig@(InfixExpression l x op@(_s, VariableExpression _ (PrimopName primop)) y) ->\n case x of\n LiteralExpression _ x' ->\n case y of\n LiteralExpression _ y' ->\n case (x', y') of\n (IntegerLiteral i1, IntegerLiteral i2) ->\n pure\n (LiteralExpression\n l\n (case primop of\n PrimopIntegerPlus -> IntegerLiteral (i1 + i2)\n PrimopIntegerTimes -> IntegerLiteral (i1 * i2)\n PrimopIntegerSubtract -> IntegerLiteral (i1 - i2)\n _ -> error \"Unexpected operation for integer literals.\"))\n (RationalLiteral i1, RationalLiteral i2) ->\n pure\n (LiteralExpression\n l\n (case primop of\n PrimopRationalPlus -> RationalLiteral (i1 + i2)\n PrimopRationalTimes -> RationalLiteral (i1 * i2)\n PrimopRationalSubtract ->\n RationalLiteral (i1 - i2)\n PrimopRationalDivide -> RationalLiteral (i1 / i2)\n _ -> error \"Unexpected operation for rational literals.\"))\n _ -> pure orig\n _ -> do\n y' <- go y\n pure (InfixExpression l x op y')\n _ -> do\n x' <- go x\n pure (InfixExpression l x' op y)\n InfixExpression l x (s, op) y -> do\n op' <- go op\n pure (InfixExpression l x (s, op') y)\n IfExpression l pr th el ->\n case pr of\n ConstructorExpression _ n\n | n == specialSigsTrue specialSigs -> pure th\n | n == specialSigsFalse specialSigs -> pure el\n _ -> IfExpression l <$> go pr <*> pure th <*> pure el\n LetExpression {} -> return x\n LambdaExpression {} -> return x\n CaseExpression l e0 alts ->\n let matches =\n map\n (\\ca -> (match e0 (caseAltPattern ca), caseAltExpression ca))\n alts\n in case listToMaybe\n (mapMaybe\n (\\(r, e) -> do\n case r of\n OK v -> pure (v, e)\n Fail -> Nothing)\n matches) of\n Just (Success subs, expr) ->\n return\n (foldr\n (\\(name, that) expr' -> substitute name that expr')\n expr\n subs)\n Just (NeedsMoreEval is, _) -> do\n e' <- expandAt typeClassEnv is specialSigs signatures e0 b\n pure (CaseExpression l e' alts)\n Nothing -> error (\"Incomplete pattern match... \" ++ show matches)\n\nexpandAt\n :: MonadThrow m\n => Map Name (Class Type Name (TypeSignature Type Name Location))\n -> [Int]\n -> SpecialSigs Name\n -> [TypeSignature Type Name Name]\n -> Expression Type Name (Location)\n -> [BindGroup Type Name (Location)]\n -> m (Expression Type Name (Location))\nexpandAt typeClassEnv is specialSigs signatures e0 b = go [0] e0\n where\n go js e =\n if is == js\n then expandWhnf typeClassEnv specialSigs signatures e b\n else case e of\n _\n | (ce@(ConstructorExpression l _), args) <- fargs e -> do\n args' <-\n sequence\n (zipWith (\\i arg -> go (js ++ [i]) arg) [0 ..] args)\n pure (foldl (ApplicationExpression l) ce args')\n | otherwise -> pure e\n\n--------------------------------------------------------------------------------\n-- Pattern matching\n\nmatch\n :: (Eq i)\n => Expression Type i l -> Pattern Type i l -> Result (Match Type i l)\nmatch = go [0]\n where\n go is val pat =\n case pat of\n BangPattern p\n | isWhnf val -> go is val p\n | otherwise -> OK (NeedsMoreEval is)\n AsPattern _l ident pat ->\n case go is val pat of\n OK (Success binds) -> OK (Success ((ident, val) : binds))\n res -> res\n WildcardPattern _ _ -> OK (Success [])\n VariablePattern _ i -> OK (Success [(i, val)])\n LiteralPattern _ l ->\n case val of\n LiteralExpression _ l'\n | l' == l -> OK (Success [])\n | otherwise -> Fail\n _ -> OK (NeedsMoreEval is)\n ConstructorPattern _ i pats\n | (constructor@ConstructorExpression {}, args) <- fargs val ->\n if fmap (const ()) constructor == ConstructorExpression () i\n then if length args == length pats\n then foldl\n (<>)\n (OK (Success []))\n (zipWith\n (\\j (arg, p) -> go (is ++ [j]) arg p)\n [0 ..]\n (zip args pats))\n else Fail\n else Fail\n | otherwise -> OK (NeedsMoreEval is)\n\nisWhnf :: Expression Type i l -> Bool\nisWhnf =\n \\case\n VariableExpression {} -> False\n ConstructorExpression {} -> True\n ConstantExpression {} -> True\n LiteralExpression {} -> True\n ApplicationExpression {} -> False\n InfixExpression {} -> False\n LetExpression {} -> False\n LambdaExpression {} -> True\n IfExpression {} -> False\n CaseExpression {} -> False\n ParensExpression {} -> False\n\n--------------------------------------------------------------------------------\n-- Expression manipulators\n\n-- | Flatten an application f x y into (f,[x,y]).\nfargs :: Expression Type i l -> (Expression Type i l, [(Expression Type i l)])\nfargs e = go e []\n where\n go (ApplicationExpression _ f x) args = go f (x : args)\n go f args = (f, args)\n\n--------------------------------------------------------------------------------\n-- Substitutions\n\nsubstitute :: Eq i => i -> Expression Type i l -> Expression Type i l -> Expression Type i l\nsubstitute i arg = go\n where\n go =\n \\case\n VariableExpression l i'\n | i == i' -> arg\n | otherwise -> VariableExpression l i'\n x@ConstructorExpression {} -> x\n x@ConstantExpression {} -> x\n ParensExpression _ e -> go e\n ApplicationExpression l f x -> ApplicationExpression l (go f) (go x)\n InfixExpression l x (s, f) y -> InfixExpression l (go x) (s, go f) (go y)\n LetExpression {} -> error \"let expressions unsupported.\"\n CaseExpression l e cases ->\n CaseExpression l (go e) (map (\\(CaseAlt l pat e') -> CaseAlt l pat (go e')) cases)\n IfExpression l a b c -> IfExpression l (go a) (go b) (go c)\n x@LiteralExpression {} -> x\n LambdaExpression l (Alternative l' args body) ->\n LambdaExpression l (Alternative l' args (go body))\n\n--------------------------------------------------------------------------------\n-- Lookups\n\nlookupName\n :: (MonadThrow m)\n => Name\n -> [BindGroup Type Name (Location)]\n -> m (Expression Type Name (Location))\nlookupName identifier binds =\n case listToMaybe (mapMaybe findIdent binds) of\n Nothing -> throwM (CouldntFindName identifier)\n Just i -> pure i\n where\n findIdent (BindGroup es is) =\n listToMaybe\n (mapMaybe\n (\\case\n ImplicitlyTypedBinding _ (i, _) [Alternative _ [] e]\n | i == identifier -> Just e\n _ -> Nothing)\n (concat is)) <|>\n listToMaybe\n (mapMaybe\n (\\case\n ExplicitlyTypedBinding _ (i, _) _ [Alternative _ [] e]\n | i == identifier -> Just e\n _ -> Nothing)\n es)\n\nlookupNameByString\n :: (MonadThrow m)\n => String\n -> [BindGroup Type Name (Location)]\n -> m (Expression Type Name (Location))\nlookupNameByString identifier binds =\n case listToMaybe (mapMaybe findIdent binds) of\n Nothing -> throwM (CouldntFindNameByString identifier)\n Just i -> pure i\n where\n findIdent (BindGroup es is) =\n listToMaybe\n (mapMaybe\n (\\case\n ImplicitlyTypedBinding _ (ValueName _ i, _) [Alternative _ [] e]\n | i == identifier -> Just e\n _ -> Nothing)\n (concat is)) <|>\n listToMaybe\n (mapMaybe\n (\\case\n ExplicitlyTypedBinding _ (ValueName _ i, _) _ [Alternative _ [] e]\n | i == identifier -> Just e\n _ -> Nothing)\n es)\n"
},
{
"path": "src/Duet/Supply.hs",
"content": "{-# LANGUAGE Strict #-}\n{-# LANGUAGE FlexibleContexts #-}\n-- |\n\nmodule Duet.Supply where\n\nimport Control.Monad.Catch\nimport Control.Monad.Supply\nimport Duet.Types\n\nsupplyValueName :: (MonadSupply Int m, Identifiable i, MonadThrow m) => i -> m Name\nsupplyValueName s = do\n i <- supply\n Identifier s' <- identifyValue s\n return (ValueName i s')\n\nsupplyConstructorName :: (MonadSupply Int m) => Identifier -> m Name\nsupplyConstructorName (Identifier s) = do\n i <- supply\n return (ConstructorName i s)\n\nsupplyDictName :: (MonadSupply Int m) => String -> m Name\nsupplyDictName s = do\n i <- supply\n return (DictName i s)\n\nsupplyDictName' :: (MonadSupply Int m, MonadThrow m) => Identifier -> m Name\nsupplyDictName' s = do\n i <- supply\n Identifier s' <- identifyValue s\n return (DictName i s')\n\nsupplyTypeName :: (MonadSupply Int m) => Identifier -> m Name\nsupplyTypeName (Identifier s) = do\n i <- supply\n return (TypeName i s)\n\nsupplyTypeVariableName :: (MonadSupply Int m) => Identifier -> m Name\nsupplyTypeVariableName (Identifier s) = do\n i <- supply\n return (TypeName i (s ++ show i))\n\nsupplyClassName :: (MonadSupply Int m) => Identifier -> m Name\nsupplyClassName (Identifier s) = do\n i <- supply\n return (ClassName i s)\n\nsupplyMethodName :: (MonadSupply Int m) => Identifier -> m Name\nsupplyMethodName (Identifier s) = do\n i <- supply\n return (MethodName i s)\n"
},
{
"path": "src/Duet/Tokenizer.hs",
"content": "{-# LANGUAGE BangPatterns #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE OverloadedStrings #-}\n\n-- | Duet syntax tokenizer.\n\nmodule Duet.Tokenizer where\n\nimport Control.Monad\nimport Data.Char\nimport Data.List\nimport Data.Text (Text)\nimport qualified Data.Text as T\nimport Duet.Printer\nimport Duet.Types\nimport Text.Parsec hiding (anyToken)\nimport Text.Parsec.Text\nimport Text.Printf\n\ntokenize :: FilePath -> Text -> Either ParseError [(Token, Location)]\ntokenize fp t = parse tokensTokenizer fp t\n\ntokensTokenizer :: Parser [(Token, Location)]\ntokensTokenizer =\n manyTill (many space >>= tokenTokenizer) (try (spaces >> eof))\n\ntokenTokenizer :: [Char] -> Parser (Token, Location)\ntokenTokenizer prespaces =\n choice\n [ if isSuffixOf \"\\n\" prespaces\n then do\n pos <- getPosition\n pure\n ( NonIndentedNewline\n , Location\n (sourceLine pos)\n (sourceColumn pos)\n (sourceLine pos)\n (sourceColumn pos))\n else unexpected \"indented newline\"\n , atomThenSpace If \"if\"\n , atomThenSpace Then \"then\"\n , atomThenSpace ClassToken \"class\"\n , atomThenSpace InstanceToken \"instance\"\n , atomThenSpace Where \"where\"\n , atomThenSpace Data \"data\"\n , atomThenSpace Else \"else\"\n , atomThenSpace ForallToken \"forall\"\n , atomThenSpace Case \"case\"\n , atomThenSpace Of \"of\"\n , atom Bang \"!\"\n , atom Period \".\"\n , atom Backslash \"\\\\\"\n , atom OpenParen \"(\"\n , atom CloseParen \")\"\n , atom Imply \"=>\"\n , atom Equals \"=\"\n , atom Bar \"|\"\n , atom Colons \"::\"\n , atom RightArrow \"->\"\n , atomThenSpace Let \"let\"\n , atomThenSpace In \"in\"\n , atom Comma \",\"\n , do tok <-\n parsing\n Operator\n (fmap\n T.pack\n (choice\n [ string \"*\"\n , string \"+\"\n , try (string \">=\")\n , try (string \"<=\")\n , string \">\"\n , string \"<\"\n , string \"/\"\n ]))\n \"operator (e.g. *, <, +, etc.)\"\n when\n (null prespaces)\n (unexpected\n (tokenString tok ++\n \", there should be spaces before and after operators.\"))\n lookAhead spaces1 (\"space after \" ++ tokenString tok)\n pure tok\n , specialParsing\n Character\n (do _ <- string \"'\"\n chars <- many1 (satisfy (\\c->c/='\\n' &&c/= '\\'')) \"character e.g. 'a'\"\n when\n (length chars > 1)\n (unexpected\n (concat\n [ \"character: you wrote\\n\"\n , \"'\" ++ ellipsis 5 chars ++ \"\\n\"\n , \"but only one character is allowed inside single quotes, like this:\\n'\" ++\n take 1 chars ++ \"'\"\n , \"\\nPerhaps you forgot to put the closing single quote?\\n\"\n , \"You may also have meant to use double quotes for text, e.g.\\n\"\n , \"\\\"\" ++ takeWhile (/= '\\'') chars ++ \"\\\"\"\n ]))\n _ <- string \"'\"\n pure (head chars))\n \"character (e.g. 'a', 'z', '9', etc.)\"\n , parsing\n String\n (do _ <- string \"\\\"\"\n chars <- many (satisfy (\\c -> c /= '\"'))\n when\n (any (== '\\\\') chars)\n (unexpected \"\\\\ character, not allowed inside a string.\")\n when\n (any (== '\\n') chars)\n (unexpected \"newline character, not allowed inside a string.\")\n _ <- string \"\\\"\" \"double quotes (\\\") to close the string\"\n pure (T.pack chars))\n \"string (e.g. \\\"hello\\\", \\\"123\\\", etc.)\"\n , parsing\n Constructor\n (do c <- satisfy isUpper\n variable <- many (satisfy (flip elem (['A' .. 'Z']++['a' .. 'z'])))\n pure (T.singleton c <> T.pack variable))\n \"constructor (e.g. “Rocket”, “Just”, etc.)\"\n , parsing\n Variable\n (do variable <-\n do start <- many1 (satisfy (flip elem (\"_\" ++ ['a' .. 'z'])))\n end <-\n many\n (satisfy (flip elem (\"_\" ++ ['A' .. 'Z'] ++['a' .. 'z'] ++ ['0' .. '9'])))\n pure (start ++ end)\n pure (T.pack variable))\n \"variable (e.g. “elephant”, “age”, “t2”, etc.)\"\n , parseNumbers prespaces\n ]\n where\n\nspaces1 :: Parser ()\nspaces1 = space >> spaces\n\nellipsis :: Int -> [Char] -> [Char]\nellipsis n text =\n if length text > 2\n then take n text ++ \"…\"\n else text\n\nspecialParsing :: (t1 -> t) -> Parser t1 -> String -> Parser (t, Location)\nspecialParsing constructor parser description = do\n start <- getPosition\n thing <- parser description\n end <- getPosition\n pure\n ( constructor thing\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))\n\natom :: t -> String -> Parser (t, Location)\natom constructor text = do\n start <- getPosition\n _ <- try (string text) smartQuotes text\n end <- getPosition\n pure\n ( constructor\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))\n\natomThenSpace :: t -> String -> Parser (t, Location)\natomThenSpace constructor text = do\n start <- getPosition\n _ <-\n try ((string text smartQuotes text) <*\n (lookAhead spaces1 (\"space or newline after \" ++ smartQuotes text)))\n end <- getPosition\n pure\n ( constructor\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))\n\nparsing :: (Text -> t) -> Parser Text -> String -> Parser (t, Location)\nparsing constructor parser description = do\n start <- getPosition\n text <- parser description\n mapM_\n (bailOnUnsupportedKeywords text)\n [ \"class\"\n , \"data\"\n , \"default\"\n , \"deriving\"\n , \"do\"\n , \"forall\"\n , \"import\"\n , \"infix\"\n , \"infixl\"\n , \"infixr\"\n , \"instance\"\n , \"module\"\n , \"if\"\n , \"then\"\n , \"else\"\n , \"case\"\n , \"newtype\"\n , \"qualified\"\n , \"type\"\n , \"where\"\n , \"foreign\"\n , \"ccall\"\n , \"as\"\n , \"safe\"\n , \"unsafe\"\n ]\n end <- getPosition\n pure\n ( constructor text\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))\n where\n supportedKeywords = [\"class\",\"data\",\"forall\",\"instance\",\"if\",\"then\",\"else\",\"case\"]\n bailOnUnsupportedKeywords text word =\n when\n (text == word)\n (unexpected\n (if elem word supportedKeywords\n then \"the keyword \" ++ curlyQuotes (T.unpack word) ++ \" isn't in the right place or is incomplete. Try adding a space after it?\"\n else (\"“\" ++ T.unpack word ++ \"”: that keyword isn't allowed, \" ++ ext)))\n where\n ext = \"but you could use this instead: \" ++ T.unpack word ++ \"_\"\n\nparseNumbers :: [a] -> Parser (Token, Location)\nparseNumbers prespaces = parser \"number (e.g. 42, 3.141, etc.)\"\n where\n parser = do\n start <- getPosition\n neg <- fmap Just (char '-') <|> pure Nothing\n let operator = do\n end <- getPosition\n pure\n ( Operator \"-\"\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))\n number\n :: (forall a. (Num a) =>\n a -> a)\n -> Parser (Token, Location)\n number f = do\n x <- many1 digit\n (do _ <- char '.'\n y <- many1 digit (\"decimal component, e.g. \" ++ x ++ \".0\")\n end <- getPosition\n pure\n ( Decimal (f (read (x ++ \".\" ++ y)))\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end))) <|>\n (do end <- getPosition\n pure\n ( Integer (f (read x))\n , Location\n (sourceLine start)\n (sourceColumn start)\n (sourceLine end)\n (sourceColumn end)))\n case neg of\n Nothing -> number id\n Just {} -> do\n when\n (null prespaces)\n (unexpected\n (curlyQuotes \"-\" ++ \", there should be a space before it.\"))\n (number (* (-1)) \"number (e.g. 123)\") <|>\n operator <* (space (\"space after operator \" ++ curlyQuotes \"-\"))\n\nsmartQuotes :: [Char] -> [Char]\nsmartQuotes t = \"“\" <> t <> \"”\"\n\nequalToken :: Token -> TokenParser Location\nequalToken p = fmap snd (satisfyToken (==p) tokenStr p)\n\n-- | Consume the given predicate from the token stream.\nsatisfyToken :: (Token -> Bool) -> TokenParser (Token, Location)\nsatisfyToken p =\n consumeToken (\\tok -> if p tok\n then Just tok\n else Nothing)\n\n-- | The parser @anyToken@ accepts any kind of token. It is for example\n-- used to implement 'eof'. Returns the accepted token.\nanyToken :: TokenParser (Token, Location)\nanyToken = consumeToken Just\n\n-- | Consume the given predicate from the token stream.\nconsumeToken :: (Token -> Maybe a) -> TokenParser (a, Location)\nconsumeToken f = do\n u <- getState\n tokenPrim\n tokenString\n tokenPosition\n (\\(tok, loc) ->\n if locationStartColumn loc > u\n then fmap (, loc) (f tok)\n else Nothing)\n\n-- | Make a string out of the token, for error message purposes.\ntokenString :: (Token, Location) -> [Char]\ntokenString = tokenStr . fst\n\ntokenStr :: Token -> [Char]\ntokenStr tok =\n case tok of\n If -> curlyQuotes \"if\"\n Then -> curlyQuotes \"then\"\n Imply -> curlyQuotes \"=>\"\n RightArrow -> curlyQuotes \"->\"\n Else -> curlyQuotes \"else\"\n Where -> curlyQuotes \"where\"\n ClassToken -> curlyQuotes \"class\"\n Data -> curlyQuotes \"data\"\n InstanceToken -> curlyQuotes \"instance\"\n Case -> curlyQuotes \"case\"\n Of -> curlyQuotes \"of\"\n Let -> curlyQuotes \"let\"\n NonIndentedNewline -> \"non-indented newline\"\n In -> curlyQuotes \"in\"\n Backslash -> curlyQuotes (\"backslash \" ++ curlyQuotes \"\\\\\")\n OpenParen -> \"opening parenthesis \" ++ curlyQuotes \"(\"\n CloseParen -> \"closing parenthesis \" ++ curlyQuotes \")\"\n Equals -> curlyQuotes \"=\"\n Colons -> curlyQuotes \"::\"\n ForallToken -> curlyQuotes \"forall\"\n Variable t -> \"variable \" ++ curlyQuotes (T.unpack t)\n Constructor t -> \"constructor \" ++ curlyQuotes (T.unpack t)\n Character !c -> \"character '\" ++ (T.unpack (T.singleton c)) ++ \"'\"\n String !t -> \"string \" ++ show t\n Operator !t -> \"operator \" ++ curlyQuotes (T.unpack t)\n Comma -> curlyQuotes \",\"\n Integer !i -> \"integer \" ++ show i\n Decimal !d -> \"decimal \" ++ printf \"%f\" d\n Bar -> curlyQuotes \"|\"\n Period -> curlyQuotes \".\"\n Bang -> curlyQuotes \"!\"\n\n-- | Update the position by the token.\ntokenPosition :: SourcePos -> (Token, Location) -> t -> SourcePos\ntokenPosition pos (_, l) _ =\n setSourceColumn (setSourceLine pos line) col\n where (line,col) = (locationStartLine l, locationStartColumn l)\n\ntype TokenParser e = forall s m. Stream s m (Token, Location) => ParsecT s Int m e\n\n-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser\n-- does not consume any input. This parser can be used to implement the\n-- \\'longest match\\' rule. For example, when recognizing keywords (for\n-- example @let@), we want to make sure that a keyword is not followed\n-- by a legal identifier character, in which case the keyword is\n-- actually an identifier (for example @lets@). We can program this\n-- behaviour as follows:\n--\n-- > keywordLet = try (do{ string \"let\"\n-- > ; notFollowedBy alphaNum\n-- > })\nnotFollowedBy' :: TokenParser (Token, Location) -> TokenParser ()\nnotFollowedBy' p =\n try ((do c <- try p\n unexpected (tokenString c)) <|>\n return ())\n\n-- | This parser only succeeds at the end of the input. This is not a\n-- primitive parser but it is defined using 'notFollowedBy'.\n--\n-- > eof = notFollowedBy anyToken \"end of input\"\nendOfTokens :: TokenParser ()\nendOfTokens = notFollowedBy' anyToken \"end of input\"\n"
},
{
"path": "src/Duet/Types.hs",
"content": "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE DeriveDataTypeable #-}\n{-# LANGUAGE FlexibleInstances #-}\n{-# LANGUAGE StandaloneDeriving #-}\n{-# LANGUAGE RankNTypes #-}\n{-# LANGUAGE KindSignatures #-}\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE DeriveTraversable #-}\n{-# LANGUAGE DeriveFunctor #-}\n{-# LANGUAGE DeriveGeneric #-}\n{-# LANGUAGE GeneralizedNewtypeDeriving #-}\n\n-- | Data types for the project.\n\nmodule Duet.Types where\n\nimport Control.DeepSeq\nimport Control.Monad.Catch\nimport Control.Monad.State\nimport Data.Data (Data, Typeable)\nimport Data.Map.Strict (Map)\nimport Data.String\nimport Data.Text (Text)\nimport GHC.Generics\nimport Text.Parsec (ParseError)\n\n-- | A declaration.\ninstance (NFData l, NFData i, NFData (t i)) => NFData (Decl t i l)\n\n\ndata Decl t i l\n = DataDecl l (DataType t i)\n -- | BindGroupDecl l (BindGroup t i l)\n | BindDecl l (Binding t i l)\n | ClassDecl l (Class t i l)\n | InstanceDecl l (Instance t i l)\n deriving (Show, Generic, Data, Typeable)\n\ninstance (NFData l, NFData i, NFData (t i)) => NFData (Binding t i l)\n\n\ndata Binding t i l\n = ImplicitBinding (ImplicitlyTypedBinding t i l)\n | ExplicitBinding (ExplicitlyTypedBinding t i l)\n deriving (Show, Generic, Data, Typeable)\n\nbindingIdentifier :: Binding t i l -> i\nbindingIdentifier =\n \\case\n ImplicitBinding i -> fst (implicitlyTypedBindingId i)\n ExplicitBinding i -> fst (explicitlyTypedBindingId i)\n\nbindingAlternatives :: Binding t i l -> [Alternative t i l]\nbindingAlternatives =\n \\case\n ImplicitBinding i -> implicitlyTypedBindingAlternatives i\n ExplicitBinding i -> explicitlyTypedBindingAlternatives i\n\ndeclLabel :: Decl t i l -> l\ndeclLabel =\n \\case\n DataDecl l _ -> l\n BindDecl l _ -> l\n ClassDecl l _ -> l\n InstanceDecl l _ -> l\n\n-- | Data type.\ninstance (NFData i, NFData (t i)) => NFData (DataType t i )\n\n\ndata DataType t i = DataType\n { dataTypeName :: i\n , dataTypeVariables :: [TypeVariable i]\n , dataTypeConstructors :: [DataTypeConstructor t i]\n } deriving (Show, Generic, Data, Typeable)\n\ndataTypeConstructor :: DataType Type Name -> Type Name\ndataTypeConstructor (DataType name vs _) =\n ConstructorType (toTypeConstructor name vs)\n\ntoTypeConstructor :: Name -> [TypeVariable Name] -> TypeConstructor Name\ntoTypeConstructor name vars =\n TypeConstructor name (foldr FunctionKind StarKind (map typeVariableKind vars))\n\ndataTypeToConstructor :: DataType t Name -> TypeConstructor Name\ndataTypeToConstructor (DataType name vs _) =\n toTypeConstructor name vs\n\n-- | A data type constructor.\ninstance (NFData i, NFData (t i)) => NFData (DataTypeConstructor t i)\n\n\ndata DataTypeConstructor t i = DataTypeConstructor\n { dataTypeConstructorName :: i\n , dataTypeConstructorFields :: [t i]\n } deriving (Show, Generic, Data, Typeable)\n\n-- | Type for a data typed parsed from user input.\ninstance (NFData i) => NFData (UnkindedType i)\n\n\ndata UnkindedType i\n = UnkindedTypeConstructor i\n | UnkindedTypeVariable i\n | UnkindedTypeApp (UnkindedType i) (UnkindedType i)\n deriving (Show, Generic, Data, Typeable)\n\n-- | Special built-in types you need for type-checking patterns and\n-- literals.\ninstance (NFData i) => NFData (SpecialTypes i )\n\n\ndata SpecialTypes i = SpecialTypes\n { specialTypesBool :: DataType Type i\n , specialTypesChar :: TypeConstructor i\n , specialTypesString :: TypeConstructor i\n , specialTypesFunction :: TypeConstructor i\n , specialTypesInteger :: TypeConstructor i\n , specialTypesRational :: TypeConstructor i\n } deriving (Show, Generic, Data, Typeable)\n\n-- | Special built-in signatures.\ninstance (NFData i) => NFData (SpecialSigs i)\n\n\ndata SpecialSigs i = SpecialSigs\n { specialSigsTrue :: i\n , specialSigsFalse :: i\n , specialSigsPlus :: i\n , specialSigsTimes :: i\n , specialSigsSubtract :: i\n , specialSigsDivide :: i\n } deriving (Show, Generic, Data, Typeable)\n\n-- | Type inference monad.\nnewtype InferT m a = InferT\n { runInferT :: StateT InferState m a\n } deriving (Monad, Applicative, Functor, MonadThrow)\n\n-- | Name is a globally unique identifier for any thing. No claim\n-- about \"existence\", but definitely uniquness. A name names one thing\n-- and one thing only.\n--\n-- So this comes /after/ the parsing step, and /before/ the\n-- type-checking step. The renamer's job is to go from Identifier -> Name.\ndata Name\n = ValueName !Int !String\n | ConstructorName !Int !String\n | TypeName !Int !String\n | ForallName !Int\n | DictName !Int String\n | ClassName !Int String\n | MethodName !Int String\n | PrimopName Primop\n deriving (Show, Generic, Data, Typeable, Eq, Ord)\ninstance NFData Name\n\n-- | Pre-defined operations.\ninstance NFData (Primop)\ndata Primop\n = PrimopIntegerPlus\n | PrimopIntegerSubtract\n | PrimopIntegerTimes\n | PrimopRationalDivide\n | PrimopRationalPlus\n | PrimopRationalSubtract\n | PrimopRationalTimes\n | PrimopStringAppend\n | PrimopStringDrop\n | PrimopStringTake\n deriving (Show, Generic, Data, Typeable, Eq, Ord, Enum, Bounded)\n\n-- | State of inferring.\ninstance NFData (InferState)\ndata InferState = InferState\n { inferStateSubstitutions :: ![Substitution Name]\n , inferStateCounter :: !Int\n , inferStateSpecialTypes :: !(SpecialTypes Name)\n } deriving (Show, Generic, Data, Typeable)\n\ndata ParseException\n = TokenizerError ParseError\n | ParserError ParseError\n deriving (Typeable, Show)\ninstance Exception ParseException\n\ndata StepException\n = CouldntFindName !Name\n | CouldntFindNameByString !String\n | TypeAtValueScope !Name\n | CouldntFindMethodDict !Name\n deriving (Typeable, Show)\ninstance Exception StepException\n\n\nnewtype UUID = UUID String\n deriving (Ord, Eq, Show, Generic, Data, Typeable)\ninstance NFData UUID\n\ninstance NFData (RenamerException)\ndata RenamerException\n = IdentifierNotInVarScope !(Map Identifier Name) !Identifier !Location\n | IdentifierNotInConScope !(Map Identifier Name) !Identifier\n | IdentifierNotInClassScope !(Map Identifier Name) !Identifier\n | IdentifierNotInTypeScope !(Map Identifier Name) !Identifier\n | NameNotInConScope ![TypeSignature Type Name Name] !Name\n | TypeNotInScope ![TypeConstructor Name] !Identifier\n | UnknownTypeVariable ![TypeVariable Name] !Identifier\n | InvalidMethodTypeVariable ![TypeVariable Name] !(TypeVariable Name)\n | KindArgMismatch (Type Name) Kind (Type Name) Kind\n | KindTooManyArgs (Type Name) Kind (Type Name)\n | ConstructorFieldKind Name (Type Name) Kind\n | MustBeStarKind (Type Name) Kind\n | BuiltinNotDefined !String\n | RenamerNameMismatch !Name\n deriving (Show, Generic, Data, Typeable, Typeable)\ninstance Exception RenamerException\n\ndata ContextException = ContextException (SpecialTypes Name) SomeException\n deriving (Show, Generic, Typeable)\ninstance Exception ContextException\n\n-- | An exception that may be thrown when reading in source code,\n-- before we do any type-checking.-}\ninstance NFData (ReadException)\ndata ReadException\n = ClassAlreadyDefined\n | NoSuchClassForInstance\n | OverlappingInstance\n | UndefinedSuperclass\n deriving (Show, Generic, Data, Typeable, Typeable)\ninstance Exception ReadException\n\ninstance NFData (ResolveException)\ndata ResolveException =\n NoInstanceFor (Predicate Type Name)\n deriving (Show, Generic, Data, Typeable, Typeable)\ninstance Exception ResolveException\n\n-- | A type error.\ninstance NFData (InferException)\ndata InferException\n = ExplicitTypeMismatch (Scheme Type Name Type) (Scheme Type Name Type)\n | ContextTooWeak\n | OccursCheckFails\n | KindMismatch\n | TypeMismatch (Type Name) (Type Name)\n | ListsDoNotUnify\n | TypeMismatchOneWay\n | NotInScope ![TypeSignature Type Name Name] !Name\n | ClassMismatch\n | MergeFail\n | AmbiguousInstance [Ambiguity Name]\n | MissingMethod\n | MissingTypeVar (TypeVariable Name) [(TypeVariable Name, Type Name)]\n\n deriving (Show, Generic, Data, Typeable, Typeable)\ninstance Exception InferException\n\n-- | Specify the type of @a@.\ninstance (NFData (t i), NFData i, NFData a) => NFData (TypeSignature t i a)\n\n\ndata TypeSignature (t :: * -> *) i a = TypeSignature\n { typeSignatureA :: a\n , typeSignatureScheme :: Scheme t i t\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\ninstance (NFData (t i), NFData i, NFData l) => NFData (BindGroup t i l)\n\n\ndata BindGroup (t :: * -> *) i l = BindGroup\n { bindGroupExplicitlyTypedBindings :: ![ExplicitlyTypedBinding t i l]\n , bindGroupImplicitlyTypedBindings :: ![[ImplicitlyTypedBinding t i l]]\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\ninstance (NFData (t i), NFData i, NFData l) => NFData (ImplicitlyTypedBinding t i l)\n\n\ndata ImplicitlyTypedBinding (t :: * -> *) i l = ImplicitlyTypedBinding\n { implicitlyTypedBindingLabel :: l\n , implicitlyTypedBindingId :: !(i, l)\n , implicitlyTypedBindingAlternatives :: ![Alternative t i l]\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\n-- | The simplest case is for explicitly typed bindings, each of which\n-- is described by the name of the function that is being defined, the\n-- declared type scheme, and the list of alternatives in its\n-- definition.\n--\n-- Haskell requires that each Alt in the definition of a given\n-- identifier has the same number of left-hand side arguments, but we\n-- do not need to enforce that here.\ninstance (NFData (t i), NFData l,NFData i) => NFData (ExplicitlyTypedBinding t i l)\n\n\ndata ExplicitlyTypedBinding t i l = ExplicitlyTypedBinding\n { explicitlyTypedBindingLabel :: l\n , explicitlyTypedBindingId :: !(i, l)\n , explicitlyTypedBindingScheme :: !(Scheme t i t)\n , explicitlyTypedBindingAlternatives :: ![(Alternative t i l)]\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\n-- | Suppose, for example, that we are about to qualify a type with a\n-- list of predicates ps and that vs lists all known variables, both\n-- fixed and generic. An ambiguity occurs precisely if there is a type\n-- variable that appears in ps but not in vs (i.e., in tv ps \\\\\n-- vs). The goal of defaulting is to bind each ambiguous type variable\n-- v to a monotype t. The type t must be chosen so that all of the\n-- predicates in ps that involve v will be satisfied once t has been\n-- substituted for v.\ninstance (NFData i) => NFData (Ambiguity i)\n\n\ndata Ambiguity i = Ambiguity\n { ambiguityTypeVariable :: !(TypeVariable i)\n , ambiguityPredicates :: ![Predicate Type i]\n } deriving (Show, Generic, Data, Typeable)\n\n-- | An Alt specifies the left and right hand sides of a function\n-- definition. With a more complete syntax for Expr, values of type\n-- Alt might also be used in the representation of lambda and case\n-- expressions.\ninstance (NFData (t i), NFData l, NFData i) => NFData (Alternative t i l)\n\n\ndata Alternative t i l = Alternative\n { alternativeLabel :: l\n , alternativePatterns :: ![Pattern t i l]\n , alternativeExpression :: !(Expression t i l)\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\n-- | Substitutions-finite functions, mapping type variables to\n-- types-play a major role in type inference.\ninstance (NFData i) => NFData (Substitution i)\n\n\ndata Substitution i = Substitution\n { substitutionTypeVariable :: !(TypeVariable i)\n , substitutionType :: !(Type i)\n } deriving (Show, Generic, Data, Typeable)\n\n-- | A type variable.\ninstance (NFData i) => NFData (TypeVariable i)\n\n\ndata TypeVariable i = TypeVariable\n { typeVariableIdentifier :: !i\n , typeVariableKind :: !Kind\n } deriving (Ord, Eq, Show, Generic, Data, Typeable)\n\n-- | An identifier used for variables.\nnewtype Identifier = Identifier\n { identifierString :: String\n } deriving (Eq, IsString, Ord, Show , Generic, Data, Typeable)\ninstance NFData Identifier\n\n-- | Haskell types can be qualified by adding a (possibly empty) list\n-- of predicates, or class constraints, to restrict the ways in which\n-- type variables are instantiated.\ninstance (NFData (t i), NFData typ, NFData i) => NFData (Qualified t i typ)\n\n\ndata Qualified t i typ = Qualified\n { qualifiedPredicates :: ![Predicate t i]\n , qualifiedType :: !typ\n } deriving (Eq, Show , Generic, Data, Typeable)\n\n-- | One of potentially many predicates.\ninstance (NFData (t i), NFData i) => NFData (Predicate t i)\n\n\ndata Predicate t i =\n IsIn i [t i]\n deriving (Eq, Show , Generic, Data, Typeable)\n\n-- | A simple Haskell type.\ninstance (NFData i) => NFData (Type i)\n\n\ndata Type i\n = VariableType (TypeVariable i)\n | ConstructorType (TypeConstructor i)\n | ApplicationType (Type i) (Type i)\n deriving (Eq, Show, Generic, Data, Typeable)\n\n-- | Kind of a type.\ninstance NFData (Kind)\ndata Kind\n = StarKind\n | FunctionKind Kind Kind\n deriving (Eq, Ord, Show, Generic, Data, Typeable)\n\ninstance NFData (Location)\ndata Location = Location\n { locationStartLine :: !Int\n , locationStartColumn :: !Int\n , locationEndLine :: !Int\n , locationEndColumn :: !Int\n } deriving (Show, Generic, Data, Typeable, Eq)\n\n-- | A Haskell expression.\ninstance (NFData (t i), NFData l,NFData i) => NFData (Expression t i l)\n\n\ndata Expression (t :: * -> *) i l\n = VariableExpression l i\n | ConstructorExpression l i\n | ConstantExpression l Identifier\n | LiteralExpression l Literal\n | ApplicationExpression l (Expression t i l) (Expression t i l)\n | InfixExpression l (Expression t i l) (String, Expression t i l) (Expression t i l)\n | LetExpression l (BindGroup t i l) (Expression t i l)\n | LambdaExpression l (Alternative t i l)\n | IfExpression l (Expression t i l) (Expression t i l) (Expression t i l)\n | CaseExpression l (Expression t i l) [CaseAlt t i l]\n | ParensExpression l (Expression t i l)\n deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\ninstance (NFData (t i), NFData l,NFData i) => NFData (CaseAlt t i l)\n\n\ndata CaseAlt t i l = CaseAlt\n { caseAltLabel :: l\n , caseAltPattern :: Pattern t i l\n , caseAltExpression :: Expression t i l\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\nexpressionLabel :: Expression t i l -> l\nexpressionLabel =\n \\case\n LiteralExpression l _ -> l\n ConstantExpression l _ -> l\n ApplicationExpression l _ _ -> l\n InfixExpression l _ _ _ -> l\n LetExpression l _ _ -> l\n LambdaExpression l _ -> l\n IfExpression l _ _ _ -> l\n CaseExpression l _ _ -> l\n VariableExpression l _ -> l\n ConstructorExpression l _ -> l\n ParensExpression l _ -> l\n\n-- | A pattern match.\ninstance (NFData l,NFData i) => NFData (Pattern t i l)\n\n\ndata Pattern (t :: * -> *) i l\n = VariablePattern l i\n | WildcardPattern l String\n | AsPattern l i (Pattern t i l)\n | LiteralPattern l Literal\n | ConstructorPattern l i [Pattern t i l]\n | BangPattern (Pattern t i l)\n deriving (Show, Generic, Data, Typeable , Eq , Functor, Traversable, Foldable)\n\npatternLabel :: Pattern ty t t1 -> t1\npatternLabel (VariablePattern loc _) = loc\npatternLabel (ConstructorPattern loc _ _) = loc\npatternLabel (WildcardPattern l _) = l\npatternLabel (AsPattern l _ _) = l\npatternLabel (LiteralPattern l _) =l\npatternLabel (BangPattern p) = patternLabel p\n\ninstance NFData (Literal)\ndata Literal\n = IntegerLiteral Integer\n | CharacterLiteral Char\n | RationalLiteral Rational\n | StringLiteral String\n deriving (Show, Generic, Data, Typeable, Eq)\n\n-- | A class.\ninstance (NFData (t i), NFData l,NFData i) => NFData (Class t i l)\n\ndata Class (t :: * -> *) i l = Class\n { classTypeVariables :: ![TypeVariable i]\n , classSuperclasses :: ![Predicate t i]\n , classInstances :: ![Instance t i l]\n , className :: i\n , classMethods :: Map i (Scheme t i t)\n } deriving (Show, Generic, Data, Typeable, Traversable, Foldable, Functor)\n\n-- | Class instance.\ninstance (NFData (t i), NFData l,NFData i) => NFData (Instance t i l)\n\n\ndata Instance (t :: * -> *) i l = Instance\n { instancePredicate :: !(Scheme t i (Predicate t))\n , instanceDictionary :: !(Dictionary t i l)\n } deriving (Show, Generic, Data, Typeable, Traversable, Foldable, Functor)\n\ninstanceClassName :: Instance t1 i t -> i\ninstanceClassName (Instance (Forall _ (Qualified _ (IsIn x _))) _) = x\n\n-- | A dictionary for a class.\ninstance (NFData (t i), NFData l,NFData i) => NFData (Dictionary t i l)\n\ndata Dictionary (t :: * -> *) i l = Dictionary\n { dictionaryName :: i\n , dictionaryMethods :: Map i (l, Alternative t i l)\n } deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)\n\n\n\n-- | A type constructor.\ninstance (NFData i) => NFData (TypeConstructor i)\n\ndata TypeConstructor i = TypeConstructor\n { typeConstructorIdentifier :: !i\n , typeConstructorKind :: !Kind\n } deriving (Eq, Show, Generic, Data, Typeable)\n\n-- | A type scheme.\ninstance (NFData (typ i), NFData (t i), NFData i) => NFData (Scheme t i typ)\n\n\ndata Scheme t i typ =\n Forall [TypeVariable i] (Qualified t i (typ i))\n deriving (Eq, Show, Generic, Data, Typeable)\n\ninstance (NFData a) => NFData (Result a)\n\n\ndata Result a\n = OK a\n | Fail\n deriving (Show, Generic, Data, Typeable, Functor)\n\ninstance Semigroup a => Semigroup (Result a) where\n Fail <> _ = Fail\n _ <> Fail = Fail\n OK x <> OK y = OK (x <> y)\n\ndata Match t i l\n = Success [(i, Expression t i l)]\n | NeedsMoreEval [Int]\n deriving (Eq, Show, Functor)\n\ninstance Semigroup (Match t i l) where\n NeedsMoreEval is <> _ = NeedsMoreEval is\n _ <> NeedsMoreEval is = NeedsMoreEval is\n Success xs <> Success ys = Success (xs <> ys)\n\nclass Identifiable i where\n identifyValue :: MonadThrow m => i -> m Identifier\n identifyType :: MonadThrow m => i -> m Identifier\n identifyClass :: MonadThrow m => i -> m Identifier\n nonrenamableName :: i -> Maybe Name\n\ninstance Identifiable Identifier where\n identifyValue = pure\n identifyType = pure\n identifyClass = pure\n nonrenamableName _ = Nothing\n\ninstance Identifiable Name where\n identifyValue =\n \\case\n ValueName _ i -> pure (Identifier i)\n ConstructorName _ c -> pure (Identifier c)\n DictName _ i -> pure (Identifier i)\n MethodName _ i -> pure (Identifier i)\n PrimopName {} -> error \"identifyValue PrimopName\"\n n -> throwM (TypeAtValueScope n)\n identifyType =\n \\case\n TypeName _ i -> pure (Identifier i)\n n -> throwM (RenamerNameMismatch n)\n identifyClass =\n \\case\n ClassName _ i -> pure (Identifier i)\n n -> throwM (RenamerNameMismatch n)\n nonrenamableName n =\n case n of\n ValueName {} -> Nothing\n ConstructorName {} -> pure n\n TypeName {} -> pure n\n ForallName {} -> pure n\n DictName {} -> pure n\n ClassName {} -> pure n\n MethodName {} -> pure n\n PrimopName {} -> pure n\n\n-- | Context for the type checker.\ninstance (NFData (t i),NFData l, NFData i) => NFData (Context t i l)\n\ndata Context t i l = Context\n { contextSpecialSigs :: SpecialSigs i\n , contextSpecialTypes :: SpecialTypes i\n , contextSignatures :: [TypeSignature t i i]\n , contextScope :: Map Identifier i\n , contextTypeClasses :: Map i (Class t i (TypeSignature t i l))\n , contextDataTypes :: [DataType t i]\n } deriving (Show, Generic, Data, Typeable)\n\n-- | Builtin context.\ninstance (NFData l,NFData (t i), NFData i) => NFData (Builtins t i l)\n\ndata Builtins t i l = Builtins\n { builtinsSpecialSigs :: SpecialSigs i\n , builtinsSpecialTypes :: SpecialTypes i\n , builtinsSignatures :: [TypeSignature t i i]\n , builtinsTypeClasses :: Map i (Class t i l)\n } deriving (Show, Generic, Data, Typeable, Traversable, Foldable, Functor)\n\ndata Token\n = If\n | Imply\n | Then\n | Data\n | ForallToken\n | Else\n | Case\n | Where\n | Of\n | Backslash\n | Let\n | In\n | RightArrow\n | OpenParen\n | CloseParen\n | Equals\n | Colons\n | Variable !Text\n | Constructor !Text\n | Character !Char\n | String !Text\n | Operator !Text\n | Period\n | Comma\n | Integer !Integer\n | Decimal !Double\n | NonIndentedNewline\n | Bar\n | ClassToken\n | InstanceToken\n | Bang\n deriving (Eq, Ord)\n\ndata Specials n = Specials\n { specialsSigs :: SpecialSigs n\n , specialsTypes :: SpecialTypes n\n }\n"
},
{
"path": "stack.yaml",
"content": "resolver: lts-20.20\n"
},
{
"path": "test/Main.hs",
"content": "{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE LambdaCase #-}\n\nimport Control.Arrow\nimport Control.Monad\nimport Control.Monad.Catch\nimport Control.Monad.Except\nimport Control.Monad.Fix\nimport Control.Monad.Supply\nimport Control.Monad.Trans\nimport Control.Monad.Writer\nimport Data.Map.Strict (Map)\nimport qualified Data.Map.Strict as M\nimport Data.Maybe\nimport Data.Monoid\nimport Data.Text (Text)\nimport qualified Data.Text as T\nimport qualified Data.Text.IO as T\nimport Data.Tuple\nimport Data.Typeable\nimport Duet.Context\nimport Duet.Errors\nimport Duet.Infer\nimport Duet.Parser\nimport Duet.Printer\nimport Duet.Renamer\nimport Duet.Resolver\nimport Duet.Stepper\nimport Duet.Supply\nimport Duet.Types\nimport Duet.Setup\n\n--------------------------------------------------------------------------------\n-- Constants\n\nmaxSteps = 200\n\ninputName = \"\"\n\nmainFunc = \"main\"\n\nexampleInputs =\n [ (\"Arithmetic\", arithmeticSource)\n , (\"Factorial\", facSource)\n , (\"Lists\", listsSource)\n , (\"Folds\", foldsSource)\n , (\"Currying\", curryinglistsSource)\n , (\"Monad\", monadSource)\n , (\"Read/Show\", readshowSource)\n , (\"Lists factorial\", listsFactorialSource)\n ]\n\n--------------------------------------------------------------------------------\n-- Shared functions\n\ncompileAndRun text =\n evalSupplyT\n (do (binds, context) <- createContext inputName (T.pack text)\n execWriterT (runStepper maxSteps context binds mainFunc))\n [1 ..] :: Either SomeException [Expression Type Name ()]\n\nprintSteps (complete, dicts) =\n either\n (const \"\")\n (unlines .\n map (printExpression defaultPrint {printDictionaries = dicts}) .\n filter mode)\n where\n mode =\n if complete\n then const True\n else cleanExpression\n\n--------------------------------------------------------------------------------\n-- Context setup\n\ndata ContextException = ContextException (SpecialTypes Name) SomeException\n deriving (Show, Typeable)\n\ninstance Exception ContextException where\n displayException (ContextException specialTypes (SomeException se)) =\n maybe\n (maybe\n (maybe\n (maybe\n (maybe\n (displayException se)\n (displayRenamerException specialTypes)\n (cast se))\n (displayInferException specialTypes)\n (cast se))\n (displayStepperException specialTypes)\n (cast se))\n (displayResolveException specialTypes)\n (cast se))\n displayParseException\n (cast se)\n\n-- | Create a context of all renamed, checked and resolved code.\ncreateContext\n :: (MonadSupply Int m, MonadThrow m, MonadCatch m)\n => String\n -> Text\n -> m ([BindGroup Type Name (TypeSignature Type Name Location)], Context Type Name Location)\ncreateContext file text = do\n do builtins <- setupEnv mempty terminalTypes\n let specials = builtinsSpecials builtins\n catch\n (do decls <- parseText file text\n (typeClasses, signatures, renamedBindings, scope, dataTypes) <-\n renameEverything decls specials builtins\n -- Type class definition\n addedTypeClasses <- addClasses builtins typeClasses\n -- Type checking\n (bindGroups, typeCheckedClasses) <-\n typeCheckModule\n addedTypeClasses\n signatures\n (builtinsSpecialTypes builtins)\n renamedBindings\n -- Type class resolution\n resolvedTypeClasses <-\n resolveTypeClasses\n typeCheckedClasses\n (builtinsSpecialTypes builtins)\n resolvedBindGroups <-\n mapM\n (resolveBindGroup\n resolvedTypeClasses\n (builtinsSpecialTypes builtins))\n bindGroups\n -- Create a context of everything\n let context =\n Context\n { contextSpecialSigs = builtinsSpecialSigs builtins\n , contextSpecialTypes = builtinsSpecialTypes builtins\n , contextSignatures = signatures\n , contextScope = scope\n , contextTypeClasses = resolvedTypeClasses\n , contextDataTypes = dataTypes\n }\n pure (resolvedBindGroups, context))\n (throwM . ContextException (builtinsSpecialTypes builtins))\n\nterminalTypes\n :: (MonadSupply Int m, MonadThrow m, MonadCatch m)\n => [SpecialTypes Name -> m (DataType Type Name)]\nterminalTypes = [makeTerminal, makeUnit]\n where\n makeUnit specialTypes = do\n name <- supplyTypeName \"Unit\"\n cons <- supplyConstructorName \"Unit\"\n pure (DataType name [] [DataTypeConstructor cons []])\n makeTerminal specialTypes = do\n name <- supplyTypeName \"Terminal\"\n return' <- supplyConstructorName \"Return\"\n getLine' <- supplyConstructorName \"GetLine\"\n print' <- supplyConstructorName \"Print\"\n a' <-\n fmap\n (flip TypeVariable StarKind)\n (supplyTypeVariableName \"a\")\n let a = VariableType a'\n terminal =\n ConstructorType\n (TypeConstructor name (FunctionKind StarKind StarKind))\n string = ConstructorType (specialTypesString specialTypes)\n pure\n (DataType\n name\n [a']\n [ DataTypeConstructor return' [a]\n , DataTypeConstructor print' [string, ApplicationType terminal a]\n , DataTypeConstructor\n getLine'\n [ ApplicationType\n (ApplicationType\n (ConstructorType (specialTypesFunction specialTypes))\n string)\n (ApplicationType terminal a)\n ]\n ])\n\n--------------------------------------------------------------------------------\n-- Stepper\n\n-- | Run the substitution model on the code.\nrunStepper\n :: (MonadWriter [Expression Type Name ()] m, MonadSupply Int m, MonadThrow m)\n => Int\n -> Context Type Name Location\n -> [BindGroup Type Name (TypeSignature Type Name Location)]\n -> String\n -> m ()\nrunStepper maxSteps context bindGroups' i = do\n e0 <- lookupNameByString i bindGroups'\n fix\n (\\loopy count lastString e -> do\n e' <- expandSeq1 context bindGroups' e\n let string = printExpression (defaultPrint) e\n when\n (string /= lastString)\n (tell [fmap (const ()) e])\n if (fmap (const ()) e' /= fmap (const ()) e) && count < maxSteps\n then do\n renameExpression\n (contextSpecials context)\n (contextScope context)\n (contextDataTypes context)\n e' >>=\n loopy (count + 1) string\n else pure ())\n 1\n \"\"\n e0\n\n-- | Filter out expressions with intermediate case, if and immediately-applied lambdas.\ncleanExpression :: Expression Type i l -> Bool\ncleanExpression =\n \\case\n CaseExpression {} -> False\n IfExpression {} -> False\n e0\n | (LambdaExpression {}, args) <- fargs e0 -> null args\n ApplicationExpression _ f x -> cleanExpression f && cleanExpression x\n _ -> True\n\n--------------------------------------------------------------------------------\n-- Example sources\n\nlistsSource =\n \"data List a = Nil | Cons a (List a)\\n\\\n \\data Tuple a b = Tuple a b\\n\\\n \\id = \\\\x -> x\\n\\\n \\not = \\\\p -> if p then False else True\\n\\\n \\foldr = \\\\cons nil l ->\\n\\\n \\ case l of\\n\\\n \\ Nil -> nil\\n\\\n \\ Cons x xs -> cons x (foldr cons nil xs)\\n\\\n \\map = \\\\f xs ->\\n\\\n \\ case xs of\\n\\\n \\ Nil -> Nil\\n\\\n \\ Cons x xs -> Cons (f x) (map f xs)\\n\\\n \\zip = \\\\xs ys ->\\n\\\n \\ case Tuple xs ys of\\n\\\n \\ Tuple Nil _ -> Nil\\n\\\n \\ Tuple _ Nil -> Nil\\n\\\n \\ Tuple (Cons x xs1) (Cons y ys1) ->\\n\\\n \\ Cons (Tuple x y) (zip xs1 ys1)\\n\\\n \\list = (Cons True (Cons False Nil))\\n\\\n \\main = zip list list\"\n\nmonadSource =\n \"class Monad (m :: Type -> Type) where\\n\\\n \\ bind :: m a -> (a -> m b) -> m b\\n\\\n \\class Applicative (f :: Type -> Type) where\\n\\\n \\ pure :: a -> f a\\n\\\n \\class Functor (f :: Type -> Type) where\\n\\\n \\ map :: (a -> b) -> f a -> f b\\n\\\n \\data Maybe a = Nothing | Just a\\n\\\n \\instance Functor Maybe where\\n\\\n \\ map =\\n\\\n \\ \\\\f m ->\\n\\\n \\ case m of\\n\\\n \\ Nothing -> Nothing\\n\\\n \\ Just a -> Just (f a)\\n\\\n \\instance Monad Maybe where\\n\\\n \\ bind =\\n\\\n \\ \\\\m f ->\\n\\\n \\ case m of\\n\\\n \\ Nothing -> Nothing\\n\\\n \\ Just v -> f v\\n\\\n \\instance Applicative Maybe where\\n\\\n \\ pure = \\\\v -> Just v\\n\\n\\\n \\main = bind (pure 1) (\\\\i -> Just (i * 2))\"\n\nfoldsSource =\n \"data List a = Nil | Cons a (List a)\\n\\\n \\foldr = \\\\f z l ->\\n\\\n \\ case l of\\n\\\n \\ Nil -> z\\n\\\n \\ Cons x xs -> f x (foldr f z xs)\\n\\\n \\foldl = \\\\f z l ->\\n\\\n \\ case l of\\n\\\n \\ Nil -> z\\n\\\n \\ Cons x xs -> foldl f (f z x) xs\\n\\\n \\list = (Cons True (Cons False Nil))\\n\\\n \\main = foldr _f _nil list\"\n\nfacSource = \"go = \\\\n res ->\\n\\\n \\ case n of\\n\\\n \\ 0 -> res\\n\\\n \\ n -> go (n - 1) (res * n)\\n\\\n \\\\n\\\n \\fac = \\\\n -> go n 1\\n\\\n \\\\n\\\n \\factorial = \\\\n ->\\n\\\n \\ case n of\\n\\\n \\ 0 -> 1\\n\\\n \\ n -> n * factorial (n - 1)\\n\\\n \\\\n\\\n \\main = fac 5\"\n\nreadshowSource = \"class Reader a where\\n\\\n \\ reader :: List Ch -> a\\n\\\n \\class Shower a where\\n\\\n \\ shower :: a -> List Ch\\n\\\n \\instance Shower Nat where\\n\\\n \\ shower = \\\\n ->\\n\\\n \\ case n of\\n\\\n \\ Zero -> Cons Z Nil\\n\\\n \\ Succ n -> Cons S (shower n)\\n\\\n \\data Nat = Succ Nat | Zero\\n\\\n \\instance Reader Nat where\\n\\\n \\ reader = \\\\cs ->\\n\\\n \\ case cs of\\n\\\n \\ Cons Z Nil -> Zero\\n\\\n \\ Cons S xs -> Succ (reader xs)\\n\\\n \\ _ -> Zero\\n\\\n \\data List a = Nil | Cons a (List a)\\n\\\n \\data Ch = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z\\n\\\n \\class Equal a where\\n\\\n \\ equal :: a -> a -> Bool\\n\\\n \\instance Equal Nat where\\n\\\n \\ equal =\\n\\\n \\ \\\\a b ->\\n\\\n \\ case a of\\n\\\n \\ Zero ->\\n\\\n \\ case b of\\n\\\n \\ Zero -> True\\n\\\n \\ _ -> False\\n\\\n \\ Succ n ->\\n\\\n \\ case b of\\n\\\n \\ Succ m -> equal n m\\n\\\n \\ _ -> False\\n\\\n \\ _ -> False\\n\\\n \\not = \\\\b -> case b of\\n\\\n \\ True -> False\\n\\\n \\ False -> True\\n\\\n \\\\n\\\n \\notEqual :: Equal a => a -> a -> Bool\\n\\\n \\notEqual = \\\\x y -> not (equal x y)\\n\\\n \\\\n\\\n \\main = equal (reader (shower (Succ Zero))) (Succ Zero)\\n\\\n \\\"\n\narithmeticSource = \"main = 2 * (10 - (5 + -3))\"\n\ncurryinglistsSource = \"data List a = Nil | Cons a (List a)\\n\\\n \\map = \\\\f xs ->\\n\\\n \\ case xs of\\n\\\n \\ Nil -> Nil\\n\\\n \\ Cons x xs -> Cons (f x) (map f xs)\\n\\\n \\multiply = \\\\x y -> x * y\\n\\\n \\doubleAll = map (multiply 2)\\n\\\n \\main = doubleAll (Cons 1 (Cons 2 Nil))\"\n\nlistsFactorialSource = \"data List a = Nil | Cons a (List a)\\n\\\n \\id = \\\\x -> x\\n\\\n \\foldr = \\\\cons nil l ->\\n\\\n \\ case l of\\n\\\n \\ Nil -> nil\\n\\\n \\ Cons x xs -> cons x (foldr cons nil xs)\\n\\\n \\enumFromTo = \\\\from to ->\\n\\\n \\ case to of\\n\\\n \\ 0 -> Nil\\n\\\n \\ _ -> Cons from (enumFromTo (from + 1) (to - 1))\\n\\\n \\fac = \\\\n -> foldr (\\\\x g n -> g (x * n)) id (enumFromTo 1 n) 1\\n\\\n \\main = fac 3\"\n\nterminalSource =\n \"main = \\n\\\n \\ Print\\n\\\n \\ \\\"Please enter your name: \\\"\\n\\\n \\ (GetLine \\n\\\n \\ (\\\\name -> \\n\\\n \\ Print \\n\\\n \\ (append \\\"Hello, \\\" (append name \\\"!\\\"))\\n\\\n \\ (Return Unit)))\"\n"
},
{
"path": "test/Spec.hs",
"content": "{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE ScopedTypeVariables #-}\n{-# LANGUAGE FlexibleContexts #-}\n{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE LambdaCase #-}\n\n-- |\n\nimport Control.Monad.Logger\nimport Control.Monad.Supply\nimport Control.Monad.Writer\nimport Data.Bifunctor\nimport Duet.Infer\nimport Duet.Parser\nimport Duet.Simple\nimport Duet.Types\nimport Test.Hspec\n\nmain :: IO ()\nmain = hspec spec\n\nspec :: SpecWith ()\nspec =\n describe\n \"Compilation\"\n (do it\n \"Basic compile and run constant\"\n (shouldBe\n (first\n (const ())\n (runNoLoggingT\n ((evalSupplyT\n (do decls <- parseText \"test\" \"main = 1\"\n (binds, ctx) <- createContext decls\n things <-\n execWriterT\n (runStepper\n 100\n ctx\n (fmap (fmap typeSignatureA) binds)\n \"main\")\n pure things)\n [1 ..]))))\n (Right [LiteralExpression () (IntegerLiteral 1)]))\n it\n \"Basic compile and run constant lambda\"\n (shouldBe\n (first\n (const ())\n (runNoLoggingT\n ((evalSupplyT\n (do decls <- parseText \"test\" \"main = (\\\\x -> x) 1\"\n (binds, ctx) <- createContext decls\n things <-\n execWriterT\n (runStepper\n 100\n ctx\n (fmap (fmap typeSignatureA) binds)\n \"main\")\n pure things)\n [1 ..]))))\n (Right\n [ ApplicationExpression\n ()\n (LambdaExpression\n ()\n (Alternative\n { alternativeLabel = ()\n , alternativePatterns =\n [VariablePattern () (ValueName 49 \"x\")]\n , alternativeExpression =\n VariableExpression () (ValueName 49 \"x\")\n }))\n (LiteralExpression () (IntegerLiteral 1))\n , LiteralExpression () (IntegerLiteral 1)\n ]))\n it\n \"Seq\"\n (shouldBe\n (second\n last\n (first\n (const ())\n (runNoLoggingT\n ((evalSupplyT\n (do decls <-\n parseText\n \"test\"\n \"seq =\\n\\\n \\ \\\\x y ->\\n\\\n \\ case x of\\n\\\n \\ !_ -> y\\n\\\n \\loop = loop\\n\\\n \\main = seq loop 1\"\n (binds, ctx) <- createContext decls\n things <-\n execWriterT\n (runStepper\n 100\n ctx\n (fmap (fmap typeSignatureA) binds)\n \"main\")\n pure things)\n [1 ..])))))\n (Right\n (CaseExpression\n ()\n (VariableExpression () (ValueName 49 \"loop\"))\n [ CaseAlt\n { caseAltLabel = ()\n , caseAltPattern = BangPattern (WildcardPattern () \"_\")\n , caseAltExpression =\n LiteralExpression () (IntegerLiteral 1)\n }\n ]))))\n"
}
]