├── .gitignore ├── .gitmodules ├── LICENSE ├── Net.md ├── README.md ├── fide ├── Fide.hs ├── HaskelineT.hs └── Main.hs ├── formality-haskell.cabal ├── graphviz ├── Graph.hs ├── inConCon.dot ├── inConCon.png ├── inConCon.svg ├── inConDup.dot ├── inConDup.png ├── inConDup.svg ├── inConEra.dot ├── inConEra.png ├── inConEra.svg ├── outConCon.dot ├── outConCon.png ├── outConCon.svg ├── outConDup.dot ├── outConDup.png ├── outConDup.svg ├── outConEra.dot ├── outConEra.png └── outConEra.svg ├── shell.nix ├── src ├── Check.hs ├── Core.hs ├── CoreSyn.hs ├── IEEE754.hs ├── Lang.hs ├── Parser.hs ├── Parser │ ├── Lang.hs │ ├── PreModule.hs │ └── Types.hs ├── Pretty.hs ├── Runtime │ └── Net.hs ├── SimplerCore.hs └── test.hs ├── stack.yaml └── test ├── Spec.hs └── Spec ├── Core.hs ├── Lang.hs ├── Net.hs ├── Parser.hs └── Parser ├── Lang.hs ├── PreModule.hs └── Utils.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | 3 | stack\.yaml\.lock 4 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "Base.fm"] 2 | path = Base.fm 3 | url = git@github.com:moonad/Base.fm.git 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Sunshine Cybernetics 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /Net.md: -------------------------------------------------------------------------------- 1 | # FM-Net v2 2 | 3 | A node is a 256 bit word 4 | A net is an array of nodes 5 | 6 | A Node has the following binary format 7 | 8 | | Name | Size | Bits | Description | 9 | |-------------|------|---------|-------------------------| 10 | | free | 1 | 0 | Node is a free variable | 11 | | node type | 1 | 1 | CON or DUP | 12 | | primarySlot | 2 | 2:3 | Primary slot points to | 13 | | leftSlot | 2 | 4:5 | Left slot points to | 14 | | rightSlot | 2 | 6:7 | Right slot points to | 15 | | meta | 56 | 8:63 | reserved for future use | 16 | | primary | 64 | 64:127 | primary slot | 17 | | left | 64 | 128:191 | left slot | 18 | | right | 64 | 192:255 | right slot | 19 | 20 | 21 | Node Slots can be one of the following: 22 | 23 | | Name | Code | Description | 24 | |------|------|-------------| 25 | | P | 00 | to Primary | 26 | | L | 01 | to Left | 27 | | R | 10 | to Right | 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Formality-Haskell 2 | 3 | A Haskell implementation of the Formality language 4 | 5 | ## Modules: 6 | 7 | - `Core`: Core language semantics 8 | - `Lang`: Parser 9 | - `Runtime.Net`:Interaction net runtime 10 | 11 | **Planned**: 12 | - `Compile.Net`: Compile Term to Interaction net 13 | - `Compile.JavaScript`: Compile Term to JavaScript 14 | - `Runtime.HOAS`: Higher-Order-Abstract-Syntax reduction 15 | - `Runtime.DeBruijn`: DeBruijn index runtime 16 | - `Runtime.Affine`: Affine Lambda Calculus runtime 17 | - `Runtime.EVM`: Ethereum Virtual Machine runtime 18 | -------------------------------------------------------------------------------- /fide/Fide.hs: -------------------------------------------------------------------------------- 1 | module Fide where 2 | 3 | import Control.Applicative 4 | import Control.Monad.Identity 5 | import Control.Monad.RWS.Lazy hiding (All) 6 | import Control.Monad.State.Strict 7 | import Control.Monad.Trans 8 | 9 | import Text.Megaparsec hiding (State) 10 | 11 | import Data.List (isPrefixOf) 12 | import qualified Data.Map.Strict as M 13 | import Data.Maybe (isJust) 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | 17 | import System.Process (callCommand) 18 | 19 | import qualified System.Console.Haskeline as H 20 | import System.Console.Haskeline.Completion 21 | import System.Console.Haskeline.MonadException 22 | 23 | import Check 24 | import Core (ID(..), Module(..), Name,eval) 25 | import qualified Core as Core 26 | import CoreSyn (runSyn, syn) 27 | import qualified CoreSyn as Syn 28 | import HaskelineT 29 | import Lang (Parser, def, expr, 30 | parseDefault, sc, sym) 31 | import qualified Lang as Lang 32 | import Pretty 33 | 34 | data FideState = FideState 35 | { _fideModule :: Module 36 | , _idCount :: ID 37 | } 38 | 39 | type Repl = HaskelineT (StateT FideState IO) 40 | 41 | repl :: (Functor m, MonadException m) -- Terminal monad ( often IO ). 42 | => HaskelineT m Text -- ^ prompt function 43 | -> HaskelineT m () -- ^ quit function 44 | -> (Text -> HaskelineT m ()) -- ^ process input function 45 | -> CompletionFunc m -- ^ Tab completion function 46 | -> HaskelineT m a -- ^ Initialiser 47 | -> m () 48 | repl prompt quit process complete initial = runHaskelineT set (initial >> loop) 49 | where 50 | loop = do 51 | promptText <- prompt 52 | input <- H.handleInterrupt (return (Just "")) $ getInputLine promptText 53 | case input of 54 | Nothing -> quit 55 | Just input 56 | | input == T.empty -> loop 57 | | otherwise -> H.handleInterrupt quit $ process input >> loop 58 | set = H.Settings 59 | { H.complete = complete 60 | , H.historyFile = Just ".history" 61 | , H.autoAddHistory = True 62 | } 63 | 64 | prompt :: Repl Text 65 | prompt = pure "Fide> " 66 | 67 | quit :: Repl () 68 | quit = outputTxtLn "Goodbye." 69 | 70 | data Command 71 | = Lets Name Lang.Term 72 | | Eval Lang.Term 73 | | Load FilePath 74 | | Quit 75 | | Help 76 | | Browse 77 | deriving (Eq, Show) 78 | 79 | parseLine :: Lang.Parser Command 80 | parseLine = sc >> line <* eof 81 | where 82 | line = choice 83 | [ try $ (sym ":help" <|> sym ":h") >> return Help 84 | , try $ (sym ":quit" <|> sym ":q") >> return Quit 85 | , try $ do 86 | sym ":let"; 87 | (n,t) <- sc >> def; 88 | optional (sym ";") 89 | return $ Lets n t 90 | , try $ do (sym ":load" <|> sym ":l") 91 | (Load . T.unpack) <$> filename <* sc 92 | , try $ do (sym ":browse"); return Browse 93 | , try $ do 94 | (n,t) <- sc >> def; 95 | optional (sym ";") 96 | return $ Lets n t 97 | , Eval <$> Lang.expr 98 | ] 99 | 100 | filename :: Parser Text 101 | filename = takeWhile1P Nothing (\s -> s /= ' ') 102 | 103 | process :: Text -> Repl () 104 | process line = do 105 | let res = parseDefault parseLine line 106 | either (\e -> liftIO $ print e) (\(c,_,_) -> procCommand c) res 107 | where 108 | procCommand :: Command -> Repl () 109 | procCommand c = case c of 110 | Browse -> do 111 | ds <- gets $ _fideModule 112 | liftIO $ print ds 113 | Help -> liftIO $ putStrLn "help text fills you with determination " 114 | Quit -> abort 115 | Lets n t -> do 116 | i <- gets _idCount 117 | terms <- gets (Core._terms . _fideModule) 118 | names <- gets (Core._names . _fideModule) 119 | let names' = M.insert n i names 120 | let j = ID $ unID i + 1 121 | modify (\s -> s { _idCount = j }) 122 | let env = Syn.SynEnv $ pure <$> names 123 | let ste = Syn.SynState j terms 124 | let (a,st,()) = runSyn env ste (syn t) 125 | case a of 126 | Left e -> liftIO $ print e 127 | Right t -> do 128 | let i' = Syn._idCount st 129 | let modl' = Core.Module (M.insert i t (Syn._terms st)) names' 130 | put $ FideState modl' i' 131 | Eval t -> do 132 | i <- gets _idCount 133 | terms <- gets (Core._terms . _fideModule) 134 | names <- gets (Core._names . _fideModule) 135 | let env = Syn.SynEnv $ pure <$> names 136 | let ste = Syn.SynState i terms 137 | let (a,st,()) = runSyn env ste (syn t) 138 | let modl = Module (Syn._terms st) names 139 | either (\e -> liftIO $ print e) (\t -> liftIO $ print $ eval t modl) a 140 | return () 141 | 142 | complete :: CompletionFunc (StateT FideState IO) 143 | complete (ante, post) 144 | | prefixes [":q ", ":quit ", ":h ", ":help "] p = noCompletion (ante, post) 145 | | prefixes [":l ", ":load "] p = completeFilename (ante, post) 146 | | prefixes [":let "] p = do 147 | ns <- gets (M.keys . Core._names . _fideModule) 148 | let f word = T.unpack <$> filter (T.isPrefixOf (T.pack word)) ns 149 | completeWord Nothing " " (pure . (map simpleCompletion) . f) (ante, post) 150 | | otherwise = do 151 | ns <- gets (M.keys . Core._names . _fideModule) 152 | let ks = [":quit", ":help", ":let", ":load"] 153 | let f word = T.unpack <$> filter (T.isPrefixOf (T.pack word)) (ks ++ ns) 154 | completeWord Nothing " " (pure . (map simpleCompletion) . f) (ante, post) 155 | where 156 | p = reverse ante 157 | 158 | prefixes :: [String] -> String -> Bool 159 | prefixes (p:ps) x = isPrefixOf p x || prefixes ps x 160 | prefixes [] x = False 161 | 162 | fide :: StateT FideState IO () 163 | fide = repl prompt quit process complete ini 164 | where 165 | ini = liftIO $ putStrLn 166 | "Welcome to Fide, the Formality interactive development environment!" 167 | 168 | 169 | -------------------------------------------------------------------------------- /fide/HaskelineT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE NoMonomorphismRestriction #-} 9 | 10 | module HaskelineT where 11 | 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | 15 | import Data.List (isPrefixOf) 16 | import Control.Applicative 17 | import Control.Monad.Fail as Fail 18 | import Control.Monad.State.Strict 19 | import Control.Monad.Reader 20 | 21 | import System.Console.Haskeline.Completion 22 | import System.Console.Haskeline.MonadException 23 | import qualified System.Console.Haskeline as H 24 | 25 | newtype HaskelineT m a = HaskelineT { unHaskeline :: H.InputT m a } 26 | deriving (Monad, Functor, Applicative, MonadIO, MonadException, MonadTrans, MonadHaskeline) 27 | 28 | -- | Run HaskelineT monad 29 | runHaskelineT :: MonadException m => H.Settings m -> HaskelineT m a -> m a 30 | runHaskelineT s m = H.runInputT s (H.withInterrupt (unHaskeline m)) 31 | 32 | class MonadException m => MonadHaskeline m where 33 | getInputLine :: Text -> m (Maybe Text) 34 | getInputChar :: Text -> m (Maybe Char) 35 | outputTxt :: Text -> m () 36 | outputTxtLn :: Text -> m () 37 | 38 | instance MonadException m => MonadHaskeline (H.InputT m) where 39 | getInputLine t = (fmap T.pack) <$> H.getInputLine (T.unpack t) 40 | getInputChar = H.getInputChar . T.unpack 41 | outputTxt = H.outputStr . T.unpack 42 | outputTxtLn = H.outputStrLn . T.unpack 43 | 44 | instance Fail.MonadFail m => Fail.MonadFail (HaskelineT m) where 45 | fail = lift . Fail.fail 46 | 47 | instance MonadState s m => MonadState s (HaskelineT m) where 48 | get = lift get 49 | put = lift . put 50 | 51 | instance MonadReader r m => MonadReader r (HaskelineT m) where 52 | ask = lift ask 53 | local f (HaskelineT m) = HaskelineT $ H.mapInputT (local f) m 54 | 55 | instance (MonadHaskeline m) => MonadHaskeline (StateT s m) where 56 | getInputLine = lift . getInputLine 57 | getInputChar = lift . getInputChar 58 | outputTxt = lift . outputTxt 59 | outputTxtLn = lift . outputTxtLn 60 | 61 | -- | Wrap a HasklineT action so that if an interrupt is thrown the shell continues as normal. 62 | tryAction :: MonadException m => HaskelineT m a -> HaskelineT m a 63 | tryAction (HaskelineT f) = HaskelineT (H.withInterrupt loop) 64 | where loop = handle (\H.Interrupt -> loop) f 65 | 66 | -- | Catch all toplevel failures. 67 | dontCrash :: (MonadIO m, H.MonadException m) => m () -> m () 68 | dontCrash m = H.catch m ( \ e@SomeException{} -> liftIO ( putStrLn ( show e ) ) ) 69 | 70 | -- | Abort the current REPL loop, and continue. 71 | abort :: MonadIO m => HaskelineT m a 72 | abort = throwIO H.Interrupt 73 | 74 | 75 | -------------------------------------------------------------------------------- /fide/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.State.Strict 4 | 5 | import qualified Data.Map.Strict as M 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | 9 | import qualified System.Console.Haskeline as H 10 | import System.Process (callCommand) 11 | 12 | import Fide 13 | import Core (ID(..), Module, emptyModule) 14 | 15 | main :: IO () 16 | main = evalStateT fide (FideState emptyModule (ID 0)) 17 | -------------------------------------------------------------------------------- /formality-haskell.cabal: -------------------------------------------------------------------------------- 1 | name: formality-haskell 2 | version: 0.1.0.0 3 | homepage: https://gitlab.com/moonad/formality-haskell#readme 4 | author: John C. Burnham 5 | license: MIT 6 | license-file: LICENSE 7 | maintainer: john@sunshinecybernetics.com 8 | category: Web 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | library 13 | default-language: Haskell2010 14 | hs-source-dirs: src 15 | exposed-modules: Runtime.Net 16 | Core 17 | Lang 18 | Parser 19 | Parser.PreModule 20 | Parser.Lang 21 | Parser.Types 22 | CoreSyn 23 | Check 24 | Pretty 25 | IEEE754 26 | build-depends: 27 | base 28 | , containers 29 | , transformers 30 | , megaparsec 31 | , mtl 32 | , text 33 | , vector 34 | , logict 35 | , equivalence 36 | , cereal 37 | , bytestring 38 | , ieee754 39 | , numeric-extras 40 | default-extensions: OverloadedStrings, MultiWayIf, PatternGuards 41 | 42 | --executable fide 43 | -- main-is: Main.hs 44 | -- build-depends: 45 | -- base 46 | -- , containers 47 | -- , transformers 48 | -- , megaparsec 49 | -- , mtl 50 | -- , text 51 | -- , vector 52 | -- , process 53 | -- , repline 54 | -- , haskeline 55 | -- other-modules: Core 56 | -- Lang 57 | -- Fide 58 | -- Check 59 | -- Pretty 60 | -- HaskelineT 61 | -- default-extensions: OverloadedStrings, MultiWayIf, PatternGuards 62 | -- hs-source-dirs: fide src 63 | 64 | test-suite test 65 | type: exitcode-stdio-1.0 66 | default-language: Haskell2010 67 | main-is: Spec.hs 68 | hs-source-dirs: test src 69 | build-depends: 70 | base 71 | , containers 72 | , transformers 73 | , hspec 74 | , QuickCheck 75 | , megaparsec 76 | , text 77 | , vector 78 | , crackNum 79 | , mtl 80 | , ieee754 81 | , cereal 82 | , bytestring 83 | , numeric-extras 84 | , raw-strings-qq 85 | default-extensions: OverloadedStrings, MultiWayIf, PatternGuards 86 | other-modules: Runtime.Net 87 | , Spec.Parser 88 | , Spec.Parser.Lang 89 | , Spec.Parser.PreModule 90 | , Spec.Parser.Utils 91 | , Spec.Net 92 | , Spec.Core 93 | , Core 94 | , CoreSyn 95 | , Lang 96 | , Check 97 | , Pretty 98 | , Parser 99 | , Parser.PreModule 100 | , Parser.Lang 101 | , Parser.Types 102 | , IEEE754 103 | 104 | -------------------------------------------------------------------------------- /graphviz/Graph.hs: -------------------------------------------------------------------------------- 1 | module Graph where 2 | 3 | import Data.List 4 | import Data.Word 5 | import System.IO 6 | import System.Process 7 | 8 | import Runtime.INet 9 | import Runtime.INode 10 | 11 | import Data.Set (Set) 12 | import qualified Data.Set as Set 13 | import qualified Data.Vector.Unboxed as V 14 | 15 | graph :: FilePath -> String -> Net -> IO () 16 | graph file str net = do 17 | writeFile file (graphVizNet net) 18 | runCommand $ "dot -Tsvg " ++ show file ++ "> " ++ str ++ ".svg" 19 | return () 20 | 21 | graphVizNet :: Net -> String 22 | graphVizNet n = intercalate "\n" $ 23 | [ "graph structs {" 24 | , " node [shape=none, fontsize=10,fontname=\"Courier\"]" 25 | , concatMap nodeString (zip [0..] (V.toList $ nodes n)) 26 | , concatMap (edgeString (redex n)) (edges $ nodes n) 27 | , "}" 28 | ] 29 | 30 | nodeString :: (Integer, Node) -> String 31 | nodeString (i, (b,_,_,_)) = case readInfoBits b of 32 | (Info True Con _ _ _ _ _ _) -> intercalate "\n" 33 | [ "\n n" ++ show i ++ " [label=<" 34 | , " " 35 | , " " 36 | , "
" ++ show i ++ "
>];" 37 | ] 38 | (Info True Dup _ _ _ _ _ _) -> intercalate "\n" 39 | [ "\n n" ++ show i ++ " [label=<" 40 | , " " 41 | , " " 42 | , "
" ++ show i ++ "
>];" 43 | ] 44 | (Info False Con _ _ _ _ _ _) -> intercalate "\n" 45 | [ "\n n" ++ show i ++ " [label=<" 46 | , " " 47 | , " " 48 | , " " 49 | , "
" ++ show i ++ "
LR
>];" 50 | ] 51 | (Info False Dup _ _ _ _ _ _) -> intercalate "\n" 52 | [ "\n n" ++ show i ++ " [label=<" 53 | , " " 54 | , " " 55 | , " " 56 | , "
" ++ show i ++ "
LR
>];" 57 | ] 58 | 59 | edgeString :: [(Word64, Word64)] -> Edge -> String 60 | edgeString rs (Edge sA iA sB iB) 61 | | (iA,iB) `elem` rs || (iB, iA) `elem` rs = 62 | concat [" n",show iA,":",show sA,"--","n",show iB,":",show sB, "[color=red]\n"] 63 | | otherwise = 64 | concat [" n",show iA,":",show sA,"--","n",show iB,":",show sB,"[color=black]\n"] 65 | 66 | data Edge = Edge Slot Word64 Slot Word64 deriving (Eq,Show, Ord) 67 | 68 | edges :: V.Vector Node -> [Edge] 69 | edges vs = Set.toList $ V.ifoldr insertRedex Set.empty vs 70 | where 71 | insertRedex :: Int -> Node -> Set Edge -> Set Edge 72 | insertRedex i (b,m,l,r) set = case (f,t) of 73 | (True, Con) -> set 74 | (True, Dup) -> insert' (Edge L i' lS l) $ set 75 | (False, _) -> 76 | insert' (Edge M i' mS m) $ 77 | insert' (Edge L i' lS l) $ 78 | insert' (Edge R i' rS r) $ set 79 | where 80 | (Info f t mS lS rS _ _ _) = readInfoBits b 81 | i' = fromIntegral i 82 | insert' n@(Edge sA iA sB iB) s 83 | | Set.member (Edge sB iB sA iA) set = s 84 | | otherwise = Set.insert n s 85 | 86 | -------------------------------------------------------------------------------- /graphviz/inConCon.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 | 8 |
0
LR
>]; 9 | n1 [label=< 10 | 11 | 12 | 13 |
1
LR
>]; 14 | n2 [label=< 15 | 16 | 17 |
2
>]; 18 | n3 [label=< 19 | 20 | 21 |
3
>]; 22 | n4 [label=< 23 | 24 | 25 |
4
>]; 26 | n5 [label=< 27 | 28 | 29 |
5
>]; 30 | n1:M--n0:M[color=red] 31 | n2:L--n0:L[color=black] 32 | n3:L--n0:R[color=black] 33 | n4:L--n1:L[color=black] 34 | n5:L--n1:R[color=black] 35 | 36 | } -------------------------------------------------------------------------------- /graphviz/inConCon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/inConCon.png -------------------------------------------------------------------------------- /graphviz/inConCon.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 18 | 0 19 | 20 | L 21 | 22 | R 23 | 24 | 25 | 26 | n1 27 | 28 | 29 | 30 | 1 31 | 32 | L 33 | 34 | R 35 | 36 | 37 | 38 | n1:M--n0:M 39 | 40 | 41 | 42 | 43 | n2 44 | 45 | 46 | 47 | 2 48 | 49 | 50 | 51 | n2:L--n0:L 52 | 53 | 54 | 55 | 56 | n3 57 | 58 | 59 | 60 | 3 61 | 62 | 63 | 64 | n3:L--n0:R 65 | 66 | 67 | 68 | 69 | n4 70 | 71 | 72 | 73 | 4 74 | 75 | 76 | 77 | n4:L--n1:L 78 | 79 | 80 | 81 | 82 | n5 83 | 84 | 85 | 86 | 5 87 | 88 | 89 | 90 | n5:L--n1:R 91 | 92 | 93 | 94 | 95 | -------------------------------------------------------------------------------- /graphviz/inConDup.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 | 8 |
0
LR
>]; 9 | n1 [label=< 10 | 11 | 12 | 13 |
1
LR
>]; 14 | n2 [label=< 15 | 16 | 17 |
2
>]; 18 | n3 [label=< 19 | 20 | 21 |
3
>]; 22 | n4 [label=< 23 | 24 | 25 |
4
>]; 26 | n5 [label=< 27 | 28 | 29 |
5
>]; 30 | n1:M--n0:M[color=red] 31 | n2:L--n0:L[color=black] 32 | n3:L--n0:R[color=black] 33 | n4:L--n1:L[color=black] 34 | n5:L--n1:R[color=black] 35 | 36 | } -------------------------------------------------------------------------------- /graphviz/inConDup.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/inConDup.png -------------------------------------------------------------------------------- /graphviz/inConDup.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 18 | 0 19 | 20 | L 21 | 22 | R 23 | 24 | 25 | 26 | n1 27 | 28 | 29 | 30 | 1 31 | 32 | L 33 | 34 | R 35 | 36 | 37 | 38 | n1:M--n0:M 39 | 40 | 41 | 42 | 43 | n2 44 | 45 | 46 | 47 | 2 48 | 49 | 50 | 51 | n2:L--n0:L 52 | 53 | 54 | 55 | 56 | n3 57 | 58 | 59 | 60 | 3 61 | 62 | 63 | 64 | n3:L--n0:R 65 | 66 | 67 | 68 | 69 | n4 70 | 71 | 72 | 73 | 4 74 | 75 | 76 | 77 | n4:L--n1:L 78 | 79 | 80 | 81 | 82 | n5 83 | 84 | 85 | 86 | 5 87 | 88 | 89 | 90 | n5:L--n1:R 91 | 92 | 93 | 94 | 95 | -------------------------------------------------------------------------------- /graphviz/inConEra.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 | 8 |
0
LR
>]; 9 | n1 [label=< 10 | 11 | 12 |
1
>]; 13 | n2 [label=< 14 | 15 | 16 |
2
>]; 17 | n0:M--n0:M[color=red] 18 | n1:L--n0:L[color=black] 19 | n2:L--n0:R[color=black] 20 | 21 | } -------------------------------------------------------------------------------- /graphviz/inConEra.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/inConEra.png -------------------------------------------------------------------------------- /graphviz/inConEra.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 18 | 0 19 | 20 | L 21 | 22 | R 23 | 24 | 25 | 26 | n0:M--n0:M 27 | 28 | 29 | 30 | 31 | n1 32 | 33 | 34 | 35 | 1 36 | 37 | 38 | 39 | n1:L--n0:L 40 | 41 | 42 | 43 | 44 | n2 45 | 46 | 47 | 48 | 2 49 | 50 | 51 | 52 | n2:L--n0:R 53 | 54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /graphviz/outConCon.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 |
0
>]; 8 | n1 [label=< 9 | 10 | 11 |
1
>]; 12 | n2 [label=< 13 | 14 | 15 |
2
>]; 16 | n3 [label=< 17 | 18 | 19 |
3
>]; 20 | n4 [label=< 21 | 22 | 23 |
4
>]; 24 | n5 [label=< 25 | 26 | 27 |
5
>]; 28 | n4:L--n2:L[color=black] 29 | n5:L--n3:L[color=black] 30 | 31 | } -------------------------------------------------------------------------------- /graphviz/outConCon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/outConCon.png -------------------------------------------------------------------------------- /graphviz/outConCon.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 0 18 | 19 | 20 | 21 | 22 | n1 23 | 24 | 25 | 1 26 | 27 | 28 | 29 | 30 | n2 31 | 32 | 33 | 34 | 2 35 | 36 | 37 | 38 | n3 39 | 40 | 41 | 42 | 3 43 | 44 | 45 | 46 | n4 47 | 48 | 49 | 50 | 4 51 | 52 | 53 | 54 | n4:L--n2:L 55 | 56 | 57 | 58 | 59 | n5 60 | 61 | 62 | 63 | 5 64 | 65 | 66 | 67 | n5:L--n3:L 68 | 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /graphviz/outConDup.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 |
0
>]; 8 | n1 [label=< 9 | 10 | 11 |
1
>]; 12 | n2 [label=< 13 | 14 | 15 |
2
>]; 16 | n3 [label=< 17 | 18 | 19 |
3
>]; 20 | n4 [label=< 21 | 22 | 23 |
4
>]; 24 | n5 [label=< 25 | 26 | 27 |
5
>]; 28 | n6 [label=< 29 | 30 | 31 | 32 |
6
LR
>]; 33 | n7 [label=< 34 | 35 | 36 | 37 |
7
LR
>]; 38 | n8 [label=< 39 | 40 | 41 | 42 |
8
LR
>]; 43 | n9 [label=< 44 | 45 | 46 | 47 |
9
LR
>]; 48 | n6:M--n4:L[color=black] 49 | n7:M--n5:L[color=black] 50 | n8:M--n2:L[color=black] 51 | n9:M--n3:L[color=black] 52 | n8:L--n6:L[color=black] 53 | n9:L--n6:R[color=black] 54 | n8:R--n7:L[color=black] 55 | n9:R--n7:R[color=black] 56 | 57 | } -------------------------------------------------------------------------------- /graphviz/outConDup.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/outConDup.png -------------------------------------------------------------------------------- /graphviz/outConDup.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 0 18 | 19 | 20 | 21 | 22 | n1 23 | 24 | 25 | 1 26 | 27 | 28 | 29 | 30 | n2 31 | 32 | 33 | 34 | 2 35 | 36 | 37 | 38 | n3 39 | 40 | 41 | 42 | 3 43 | 44 | 45 | 46 | n4 47 | 48 | 49 | 50 | 4 51 | 52 | 53 | 54 | n5 55 | 56 | 57 | 58 | 5 59 | 60 | 61 | 62 | n6 63 | 64 | 65 | 66 | 6 67 | 68 | L 69 | 70 | R 71 | 72 | 73 | 74 | n6:M--n4:L 75 | 76 | 77 | 78 | 79 | n7 80 | 81 | 82 | 83 | 7 84 | 85 | L 86 | 87 | R 88 | 89 | 90 | 91 | n7:M--n5:L 92 | 93 | 94 | 95 | 96 | n8 97 | 98 | 99 | 100 | 8 101 | 102 | L 103 | 104 | R 105 | 106 | 107 | 108 | n8:M--n2:L 109 | 110 | 111 | 112 | 113 | n8:L--n6:L 114 | 115 | 116 | 117 | 118 | n8:R--n7:L 119 | 120 | 121 | 122 | 123 | n9 124 | 125 | 126 | 127 | 9 128 | 129 | L 130 | 131 | R 132 | 133 | 134 | 135 | n9:M--n3:L 136 | 137 | 138 | 139 | 140 | n9:L--n6:R 141 | 142 | 143 | 144 | 145 | n9:R--n7:R 146 | 147 | 148 | 149 | 150 | -------------------------------------------------------------------------------- /graphviz/outConEra.dot: -------------------------------------------------------------------------------- 1 | graph structs { 2 | node [shape=none, fontsize=10,fontname="Courier"] 3 | 4 | n0 [label=< 5 | 6 | 7 |
0
>]; 8 | n1 [label=< 9 | 10 | 11 |
1
>]; 12 | n2 [label=< 13 | 14 | 15 |
2
>]; 16 | n1:L--n1:L[color=black] 17 | n2:L--n2:L[color=black] 18 | 19 | } -------------------------------------------------------------------------------- /graphviz/outConEra.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Soonad/Formality-Haskell/c2aebe3daeb1031399fd33986729722906520e89/graphviz/outConEra.png -------------------------------------------------------------------------------- /graphviz/outConEra.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | structs 11 | 12 | 13 | 14 | n0 15 | 16 | 17 | 0 18 | 19 | 20 | 21 | 22 | n1 23 | 24 | 25 | 26 | 1 27 | 28 | 29 | 30 | n1:L--n1:L 31 | 32 | 33 | 34 | 35 | n2 36 | 37 | 38 | 39 | 2 40 | 41 | 42 | 43 | n2:L--n2:L 44 | 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | {ghc}: 2 | with (import {}); 3 | 4 | haskell.lib.buildStackProject { 5 | inherit ghc; 6 | name = "myEnv"; 7 | buildInputs = [ zlib ]; 8 | buildPhase = '' 9 | export LANG=en_US.UTF-8 10 | ''; 11 | } 12 | -------------------------------------------------------------------------------- /src/Check.hs: -------------------------------------------------------------------------------- 1 | module Check where 2 | 3 | import Prelude hiding (log) 4 | 5 | import qualified Data.Map.Strict as M 6 | import Data.Maybe 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | 12 | import Control.Monad.Except 13 | import Control.Monad.Reader 14 | import Control.Monad.RWS hiding (All) 15 | import Control.Monad.State 16 | 17 | import Core 18 | 19 | data CheckEnv = CheckEnv 20 | { _module :: Module 21 | , _context :: [Binder] 22 | , _erased :: Eras 23 | } deriving (Show, Eq, Ord) 24 | 25 | data Binder = Binder 26 | { _name :: Name 27 | , _type :: Term 28 | , _eras :: Eras 29 | } deriving (Show, Eq, Ord) 30 | 31 | data CheckLog = CheckLog 32 | { _logs :: [(Term, Term, [Binder])] 33 | , _constraints :: Set Constraint 34 | } deriving Show 35 | 36 | instance Semigroup CheckLog where 37 | (<>) (CheckLog l c) (CheckLog l' c') = CheckLog (l <> l') (c <> c') 38 | 39 | instance Monoid CheckLog where 40 | mappend = (<>) 41 | mempty = CheckLog mempty mempty 42 | 43 | type Constraint = (CheckEnv, Term, Term) 44 | 45 | data CheckState = CheckState 46 | { _holCount :: Int 47 | , _refTypes :: M.Map Name Term 48 | } deriving Show 49 | 50 | data CheckError 51 | = ErasedInKeptPosition Name 52 | | ErasureMismatch Term 53 | | UnboundVariable Int CheckEnv 54 | | UndefinedRefInModule Name Module 55 | deriving Show 56 | 57 | type Check a = ExceptT CheckError (RWS CheckEnv CheckLog CheckState) a 58 | 59 | binder :: (Name,Term,Eras) -> Check a -> Check a 60 | binder (n,h,e) = local (extend (Binder n h e)) 61 | 62 | erased :: Check Term -> Check Term 63 | erased = local (\env -> env { _erased = Eras}) 64 | 65 | writeLog :: (Term, Term, [Binder]) -> Check () 66 | writeLog l = tell $ CheckLog (pure l) Set.empty 67 | 68 | constrain :: (Term,Term) -> Check () 69 | constrain (x,y) = do 70 | e <- ask 71 | let c = (e,x,y) 72 | tell $ CheckLog [] (Set.singleton c) 73 | 74 | expect :: Term -> Term -> Check Term 75 | expect t x = do xT <- check x; constrain (t,xT); return xT 76 | 77 | newHole :: Check Term 78 | newHole= do 79 | c <- gets _holCount 80 | modify (\s -> s {_holCount = c + 1}) 81 | return $ Hol (T.pack $ "#c" ++ show c) 82 | 83 | extend :: Binder -> CheckEnv -> CheckEnv 84 | extend c env = env { _context = c : (_context env) } 85 | 86 | check :: Term -> Check Term 87 | check term = case term of 88 | Var i -> do 89 | ctx <- asks _context 90 | eras <- asks _erased 91 | when (i < 0 || i >= length ctx) (ask >>= (throwError . UnboundVariable i)) 92 | let (Binder n t e) = ctx !! i 93 | when (e == Eras && eras == Keep) (throwError $ ErasedInKeptPosition n) 94 | return $ (shift (i + 1) 0 t) 95 | Typ -> return Typ 96 | All name from e to -> do 97 | erased $ expect Typ from 98 | erased $ binder (name,from,e) $ expect Typ to 99 | return Typ 100 | Lam name from eras body -> do 101 | e <- asks _erased 102 | erased $ expect Typ from 103 | to <- erased $ binder (name,from,eras) $ check body 104 | let typ = All name from eras to 105 | erased $ check typ 106 | return $ typ 107 | App fun arg e -> do 108 | funType <- local (\env -> env {_erased = e}) $ check fun 109 | argType <- check arg 110 | case funType of 111 | All _ from e' to -> do 112 | when (e /= e') (throwError $ ErasureMismatch term) 113 | constrain (from, argType) 114 | return (subst arg 0 to) 115 | _ -> do 116 | (h1,h2) <- (,) <$> newHole <*> newHole 117 | e1 <- asks _erased 118 | constrain (funType, All "_" h1 e (App h2 (Var 0) e1)) 119 | constrain (argType, h1) 120 | return $ App h2 arg e1 121 | Slf n t -> binder (n, Slf n t, Keep) (expect Typ t) 122 | New t x -> do 123 | h <- newHole 124 | tT <- expect (Slf "_" h) t 125 | xT <- expect (subst (Ann t (New t x)) 0 h) x 126 | return t 127 | Use x -> do 128 | h <- newHole 129 | xT <- expect (Slf "_" h) x 130 | return (subst x 0 h) 131 | --Num -> return Typ 132 | --Val _ -> return Num 133 | --Op1 o a b -> expect Num b 134 | --Op2 o a b -> expect Num a >> expect Num b 135 | --Ite c t f -> do 136 | -- cT <- expect Num c 137 | -- tT <- check t 138 | -- expect tT f 139 | -- Logs in Writer monad 140 | Log m x -> do 141 | mT <- check m 142 | mod <- asks _module 143 | ctx <- asks _context 144 | writeLog (m, eval (erase mT) mod, ctx) 145 | check x 146 | Hol n -> return $ Hol (n `T.append` "_type") 147 | Ref n _ -> do 148 | ds <- asks (_defs . _module) 149 | rs <- gets _refTypes 150 | case (M.lookup n ds, M.lookup n rs) of 151 | (Just t, Just tT) -> return tT 152 | (Just t , Nothing) -> do 153 | tT <- check t 154 | modify (\s -> s { _refTypes = M.insert n tT (_refTypes s)}) 155 | return tT 156 | _ -> do 157 | m <- asks _module 158 | throwError $ UndefinedRefInModule n m 159 | Ann t x -> expect t x 160 | 161 | runCheck :: CheckEnv 162 | -> CheckState 163 | -> Check a 164 | -> (Either CheckError a, CheckState, CheckLog) 165 | runCheck env ste = (\x -> runRWS x env ste) . runExceptT 166 | 167 | checkTerm :: Term -> (Either CheckError Term, CheckState, CheckLog) 168 | checkTerm = 169 | let env = CheckEnv emptyModule [] Keep 170 | ste = CheckState 0 M.empty 171 | in (runCheck env ste) . check 172 | 173 | checkModule :: Module -> Term -> (Either CheckError Term, CheckState, CheckLog) 174 | checkModule mod = 175 | let env = CheckEnv mod [] Keep 176 | ste = CheckState 0 M.empty 177 | in (runCheck env ste) . check 178 | -------------------------------------------------------------------------------- /src/Core.hs: -------------------------------------------------------------------------------- 1 | module Core where 2 | 3 | import Data.Map.Strict (Map) 4 | import qualified Data.Map.Strict as M 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import Prelude hiding (floor) 10 | 11 | import Data.Bits (complement, xor, (.&.), (.|.)) 12 | import qualified Data.Bits as Bits 13 | import qualified Data.ByteString as B 14 | import Data.Word 15 | 16 | import Control.Monad.Except 17 | import Control.Monad.Identity 18 | import Control.Monad.Reader 19 | import Control.Monad.RWS.Lazy hiding (All) 20 | import Control.Monad.State 21 | 22 | import IEEE754 23 | import Numeric.Extras 24 | import Numeric.IEEE 25 | 26 | type Name = Text 27 | 28 | data Eras = Eras -- Erase from runtime 29 | | Keep -- Keep at runtime 30 | deriving (Show, Eq, Ord) 31 | 32 | -- Core.Term 33 | data Term 34 | = Var Int -- Variable 35 | | Typ -- Type type 36 | | All Name Term Eras Term -- Forall 37 | | Lam Name Term Eras Term -- Lambda 38 | | App Term Term Eras -- Application 39 | | Slf Name Term -- Self-type 40 | | New Term Term -- Self-type introduction 41 | | Use Term -- Self-type elimination 42 | | Dbl -- floating point number type 43 | | F64 Double -- floating point value 44 | | Wrd -- integer number type 45 | | U64 Word64 -- integer value 46 | | Op1 Op FNum Term -- Unary operation (curried) 47 | | Op2 Op Term Term -- Binary operation 48 | | Ite Term Term Term -- If-then-else 49 | | Ann Term Term -- Type annotation 50 | | Log Term Term -- inline log 51 | | Hol Name -- type hole or metavariable 52 | | Ref Name Cont -- reference to a definition 53 | deriving (Eq, Show, Ord) 54 | 55 | newtype Cont = Cont { _cont :: Term -> Term } 56 | 57 | -- Cont is a continuation for correctin deBruijn index alignment when we 58 | -- dereference. Since the only functions in here should 59 | -- be `shift` and `subst` we could defunctionalize it with 60 | -- 61 | -- | Ref Name [Cont] 62 | -- 63 | -- data Cont = Shift Int Int | Subst Term Int 64 | -- 65 | -- and then refunctionalize in `deref` 66 | 67 | instance Eq Cont where 68 | a == b = True 69 | 70 | instance Show Cont where 71 | show a = "_" 72 | 73 | instance Ord Cont where 74 | compare a b = EQ 75 | 76 | 77 | data FNum = W Word64 | D Double deriving (Show, Eq, Ord) 78 | 79 | data Module = Module 80 | { _defs :: M.Map Name Term -- Either top-level or local definitions 81 | } deriving (Eq, Show, Ord) 82 | 83 | emptyModule :: Module 84 | emptyModule = Module M.empty 85 | 86 | -- shift DeBruijn indices by an increment above a depth in a term 87 | shift :: Int -> Int -> Term -> Term 88 | shift inc dep term = let go x = shift inc dep x in case term of 89 | Var i -> Var (if i < dep then i else (i + inc)) 90 | All n h e b -> All n (go h) e (shift inc (dep + 1) b) 91 | Lam n h e b -> Lam n (go h) e (shift inc (dep + 1) b) 92 | App f a e -> App (go f) (go a) e 93 | Slf n t -> Slf n (shift inc (dep + 1) t) 94 | New t x -> New (go t) (go x) 95 | Use x -> Use (go x) 96 | Op1 o a b -> Op1 o a (go b) 97 | Op2 o a b -> Op2 o (go a) (go b) 98 | Ite c t f -> Ite (go c) (go t) (go f) 99 | Ann t x -> Ann (go t) (go x) 100 | Log m x -> Log (go m) (go x) 101 | Ref n f -> Ref n (Cont $ shift inc dep . _cont f) 102 | x -> x 103 | 104 | -- substitute a value for an index at a certain depth in a term 105 | subst :: Term -> Int -> Term -> Term 106 | subst v dep term = 107 | let v' = shift 1 0 v 108 | go x = subst v dep x 109 | in 110 | case term of 111 | Var i -> if i == dep then v else Var (i - if i > dep then 1 else 0) 112 | All n h e b -> All n (go h) e (subst v' (dep + 1) b) 113 | Lam n h e b -> Lam n (go h) e (subst v' (dep + 1) b) 114 | App f a e -> App (go f) (go a) e 115 | Slf n t -> Slf n (subst v' (dep + 1) t) 116 | New t x -> New (go t) (go x) 117 | Use x -> Use (go x) 118 | Op1 o a b -> Op1 o a (go b) 119 | Op2 o a b -> Op2 o (go a) (go b) 120 | Ite c t f -> Ite (go c) (go t) (go f) 121 | Ann t x -> Ann (go t) (go x) 122 | Log m x -> Log (go m) (go x) 123 | Ref n f -> Ref n (Cont $ subst v dep . _cont f) 124 | x -> x 125 | 126 | substMany :: Term -> [Term] -> Int -> Term 127 | substMany t vals d = go t vals d 0 128 | where 129 | l = length vals - 1 130 | go t (v:vs) d i = go (subst (shift (l - i) 0 v) (d + l - i) t) vs d (i + 1) 131 | go t [] d i = t 132 | 133 | deref :: Name -> Cont -> Module -> Term 134 | deref n f defs = maybe (Ref n f) (_cont f) (M.lookup n (_defs defs)) 135 | 136 | -- deBruijn 137 | eval :: Term -> Module -> Term 138 | eval term mod = go term 139 | where 140 | go :: Term -> Term 141 | go t = case t of 142 | All n h e b -> All n h e b 143 | Lam n h e b -> Lam n h e (go b) 144 | App f a e -> case go f of 145 | Lam n h e b -> go (subst a 0 b) 146 | f -> App f (go a) e 147 | New t x -> go x 148 | Use x -> go x 149 | Op1 o a b -> case go b of 150 | U64 n -> op o a (W n) 151 | F64 n -> op o a (D n) 152 | x -> Op1 o a x 153 | Op2 o a b -> case go a of 154 | U64 n -> go (Op1 o (W n) b) 155 | F64 n -> go (Op1 o (D n) b) 156 | x -> Op2 o x b 157 | Ite c t f -> case go c of 158 | U64 n -> if n > 0 then go t else go f 159 | x -> Ite x t f 160 | Ann t x -> go x 161 | Log m x -> Log (go m) (go x) 162 | Ref n f -> case (deref n f mod) of 163 | Ref n f -> go (deref n f mod) 164 | x -> go x 165 | _ -> t 166 | 167 | -- for debugging 168 | debug_eval :: Term -> Module -> IO Term 169 | debug_eval term mod = go "top" term 170 | where 171 | go :: String -> Term -> IO Term 172 | go n t = do 173 | putStrLn $ n ++ " START: " ++ show t 174 | t' <- go_inner t 175 | putStrLn $ n ++ " END" 176 | return t' 177 | 178 | go_inner :: Term -> IO Term 179 | go_inner t = case t of 180 | All n h e b -> return $ All n h e b 181 | Lam n h e b -> Lam n h e <$> (go "Lam" b) 182 | App f a e -> do 183 | f <- go "App" f 184 | case f of 185 | Lam n h e b -> do 186 | (putStrLn $ "substituting " ++ show b ++ " <- " ++ show a) 187 | go "Subst" (subst a 0 b) 188 | f -> App f <$> (go "noLamArg" a) <*> return e 189 | New t x -> go "New" x 190 | Use x -> go "Use" x 191 | Op1 o a b -> do 192 | b <- go "Op1.b" b 193 | case b of 194 | U64 n -> return $ op o a (W n) 195 | F64 n -> return $ op o a (D n) 196 | x -> return $ Op1 o a x 197 | Op2 o a b -> do 198 | a <- go "Op2.a" a 199 | case a of 200 | U64 n -> go "Op2.b" (Op1 o (W n) b) 201 | F64 n -> go "Op2.b" (Op1 o (D n) b) 202 | x -> return $ Op2 o x b 203 | Ite c t f -> do 204 | c <- go "Ite.c" c 205 | case c of 206 | U64 n -> if n > 0 then go "Ite.t" t else go "Ite.f" f 207 | x -> return $ Ite x t f 208 | Ann t x -> go "Ann" x 209 | Log m x -> Log <$> (go "Log.m" m) <*> (go "Log.x" x) 210 | Ref n f -> do 211 | putStrLn $ show t 212 | case (deref n f mod) of 213 | Ref n f -> go "derefAgain" (deref n f mod) 214 | x -> do 215 | (putStrLn $ "Dereferencing " ++ T.unpack n ++ " <- " ++ show x) 216 | (go "Deref" x) 217 | _ -> return $ t 218 | 219 | erase :: Term -> Term 220 | erase term = case term of 221 | All n h e b -> All n (erase h) e (erase b) 222 | Lam n h Eras b -> erase $ subst (Hol "#erased") 0 b 223 | Lam n h e b -> Lam n (erase h) e (erase b) 224 | App f a Eras -> erase f 225 | App f a e -> App (erase f) (erase a) e 226 | Op1 o a b -> Op1 o a (erase b) 227 | Op2 o a b -> Op2 o (erase a) (erase b) 228 | Ite c t f -> Ite (erase c) (erase t) (erase f) 229 | Slf n t -> Slf n (erase t) 230 | New t x -> erase x 231 | Use x -> erase x 232 | Ann t x -> erase x 233 | Log m x -> Log (erase m) (erase x) 234 | _ -> term 235 | 236 | data Op 237 | = ADD | SUB | MUL | DIV | MOD | EQL | GTH | LTH 238 | | AND | BOR | XOR | NOT | SHR | SHL | ROR | ROL 239 | | MAX | MIN | POW | CLZ | CTZ | CNT | UTOF | FTOU 240 | | EXP | EXPM | LOGB | LOGP | SQRT | CBRT | HYPT | ERF 241 | | FLOR | CEIL | NRST | NAN | INF | TRNC | CONV | COPY 242 | | SIN | COS | TAN | ASIN | ACOS | ATAN 243 | | SINH | COSH | TANH | ASNH | ACSH | ATNH 244 | deriving (Eq, Show, Ord) 245 | 246 | 247 | -- A general principle with `op` is that we should avoid making the 248 | -- implementation (in this case Haskell) runtime error. i.e. all the primitive 249 | -- Formality operations should be total and we should rely on type-safe 250 | -- user-level librarys for partial functions like division. DIV is not division, 251 | -- it is division extended with the points DIV(x,0) = 0. 252 | -- 253 | -- See https://www.hillelwayne.com/post/divide-by-zero/ for further discussion 254 | -- of whether this choice is reasonable 255 | 256 | -- TODO: Find and eliminate other possible runtime errors in this function 257 | 258 | op :: Op -> FNum -> FNum -> Term 259 | op op a b 260 | | ADD <- op, W a <- a, W b <- b = U64 $ a + b 261 | | ADD <- op, D a <- a, D b <- b = F64 $ a + b 262 | | SUB <- op, W a <- a, W b <- b = U64 $ a - b 263 | | SUB <- op, D a <- a, D b <- b = F64 $ a - b 264 | | MUL <- op, W a <- a, W b <- b = U64 $ a * b 265 | | MUL <- op, D a <- a, D b <- b = F64 $ a * b 266 | | DIV <- op, W a <- a, W 0 <- b = U64 $ 0 267 | | DIV <- op, W a <- a, W b <- b = U64 $ a `div` b 268 | | DIV <- op, D a <- a, D b <- b = F64 $ a / b 269 | | MOD <- op, W a <- a, W b <- b = U64 $ a `mod` b 270 | | MOD <- op, D a <- a, D b <- b = F64 $ a `fmod` b 271 | | EQL <- op, W a <- a, W b <- b = U64 $ if a == b then 1 else 0 272 | | EQL <- op, D a <- a, D b <- b = U64 $ if a == b then 1 else 0 273 | | GTH <- op, W a <- a, W b <- b = U64 $ if a > b then 1 else 0 274 | | GTH <- op, D a <- a, D b <- b = U64 $ if a > b then 1 else 0 275 | | LTH <- op, W a <- a, W b <- b = U64 $ if a < b then 1 else 0 276 | | LTH <- op, D a <- a, D b <- b = U64 $ if a < b then 1 else 0 277 | | MIN <- op, W a <- a, W b <- b = U64 $ a `min` b 278 | | MIN <- op, D a <- a, D b <- b = F64 $ a `minNaN` b 279 | | MAX <- op, W a <- a, W b <- b = U64 $ a `max` b 280 | | MAX <- op, D a <- a, D b <- b = F64 $ a `maxNaN` b 281 | | POW <- op, W a <- a, W b <- b = U64 $ a ^ b 282 | | POW <- op, D a <- a, D b <- b = F64 $ a ** b 283 | | AND <- op, W a <- a, W b <- b = U64 $ a .&. b 284 | | BOR <- op, W a <- a, W b <- b = U64 $ a .|. b 285 | | XOR <- op, W a <- a, W b <- b = U64 $ a `xor` b 286 | | NOT <- op, W b <- b = U64 $ complement b 287 | | SHR <- op, W a <- a, W b <- b = U64 $ Bits.shiftR b (fromIntegral a) 288 | | SHL <- op, W a <- a, W b <- b = U64 $ Bits.shiftL b (fromIntegral a) 289 | | ROR <- op, W a <- a, W b <- b = U64 $ Bits.rotateR b (fromIntegral a) 290 | | ROL <- op, W a <- a, W b <- b = U64 $ Bits.rotateL b (fromIntegral a) 291 | | CLZ <- op, W b <- b = U64 $ cst $ Bits.countLeadingZeros b 292 | | CTZ <- op, W b <- b = U64 $ cst $ Bits.countTrailingZeros b 293 | | CNT <- op, W b <- b = U64 $ cst $ Bits.popCount b 294 | | SQRT <- op, D b <- b = F64 $ sqrt b 295 | | NAN <- op, D b <- b = U64 $ if isNaN b then 1 else 0 296 | | INF <- op, D b <- b = U64 $ if isInfinite b then 1 else 0 297 | | COPY <- op, D a <- a, D b <- b = F64 $ copySign a b 298 | | EXP <- op, D b <- b = F64 $ exp b 299 | | EXPM <- op, D b <- b = F64 $ expm1 b 300 | | LOGB <- op, D a <- a, D b <- b = F64 $ logBase a b 301 | | LOGP <- op, D b <- b = F64 $ log1p b 302 | | SIN <- op, D b <- b = F64 $ sin b 303 | | COS <- op, D b <- b = F64 $ cos b 304 | | TAN <- op, D b <- b = F64 $ tan b 305 | | ASIN <- op, D b <- b = F64 $ asin b 306 | | ACOS <- op, D b <- b = F64 $ acos b 307 | | ATAN <- op, D b <- b = F64 $ atan b 308 | | SINH <- op, D b <- b = F64 $ sinh b 309 | | COSH <- op, D b <- b = F64 $ cosh b 310 | | TANH <- op, D b <- b = F64 $ tanh b 311 | | ASNH <- op, D b <- b = F64 $ asinh b 312 | | ACSH <- op, D b <- b = F64 $ acosh b 313 | | ATNH <- op, D b <- b = F64 $ atanh b 314 | | CBRT <- op, D b <- b = F64 $ cbrt b 315 | | HYPT <- op, D a <- a, D b <- b = F64 $ hypot a b 316 | | ERF <- op, D b <- b = F64 $ erf b 317 | | NRST <- op, D b <- b = U64 $ round b 318 | | CEIL <- op, D b <- b = F64 $ ceil b 319 | | FLOR <- op, D b <- b = F64 $ floor b 320 | | TRNC <- op, D b <- b = F64 $ trunc b 321 | | CONV <- op, W b <- b = F64 $ fromIntegral b 322 | | UTOF <- op, W b <- b = F64 $ utof b 323 | | FTOU <- op, D b <- b = U64 $ ftou b 324 | | otherwise = error $ "UndefinedArithmetic Op" 325 | -- the only error op should raise is when there's an (OP, FNum, FNum) 326 | -- combination outside of this set. This is a language implementation error 327 | -- and should be impossible to generate from user-space 328 | where 329 | cst = fromIntegral 330 | -------------------------------------------------------------------------------- /src/CoreSyn.hs: -------------------------------------------------------------------------------- 1 | module CoreSyn where 2 | 3 | import Data.List hiding (group) 4 | import Data.Map.Strict (Map) 5 | import qualified Data.Map.Strict as M 6 | import Data.Maybe (fromJust, isJust) 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Data.Void 12 | import Data.Char 13 | 14 | import Control.Monad (void) 15 | import Control.Monad.Except 16 | import Control.Monad.Identity 17 | import Control.Monad.RWS.Lazy hiding (All) 18 | 19 | import Core hiding (_terms) 20 | import qualified Lang as Lang 21 | 22 | import qualified Parser as P 23 | 24 | type Syn a = ExceptT SynError (RWS SynEnv () SynState) a 25 | 26 | data SynState = SynState 27 | { _idCount :: Int 28 | , _terms :: Map Name Term -- All definitions 29 | } deriving Show 30 | 31 | newName :: Name -> Syn Name 32 | newName n = do 33 | i <- gets _idCount 34 | modify (\s -> s { _idCount = i + 1 }) 35 | return $ T.concat ["$", n, T.pack (show i)] 36 | 37 | data SynEnv = SynEnv 38 | { _refs :: Map Name [Name] 39 | } deriving Show 40 | 41 | withNames :: Map Name Name -> Syn a -> Syn a 42 | withNames ns p = 43 | local (\e -> e { _refs = M.unionWith (++) (pure <$> ns) (_refs e)}) p 44 | 45 | data SynError 46 | = UndefinedReference Name Int Int (Map Name [Name]) 47 | deriving (Show, Eq) 48 | 49 | synTerm :: Lang.Term -> Syn Term 50 | synTerm term = case term of 51 | Lang.Var n -> return $ Var n 52 | Lang.Typ -> return $ Typ 53 | Lang.All n h e b -> All n <$> syn h <*> return e <*> syn b 54 | Lang.Lam n h e b -> Lam n <$> syn h <*> return e <*> syn b 55 | Lang.App f a e -> App <$> syn f <*> syn a <*> return e 56 | Lang.Slf n t -> Slf n <$> syn t 57 | Lang.New t x -> New <$> syn t <*> syn x 58 | Lang.Use x -> Use <$> syn x 59 | Lang.Dbl -> return Dbl 60 | Lang.F64 n -> return $ F64 n 61 | Lang.Wrd -> return Wrd 62 | Lang.U64 n -> return $ U64 n 63 | Lang.Let ds t -> do ns <- synBlock ds; withNames ns $ syn t 64 | Lang.Opr o a b -> Op2 o <$> syn a <*> syn b 65 | Lang.Ite c t f -> Ite <$> syn c <*> syn t <*> syn f 66 | Lang.Ann t x -> Ann <$> syn t <*> syn x 67 | Lang.Log m x -> Log <$> syn m <*> syn x 68 | Lang.Hol n -> return $ Hol n 69 | Lang.Whn [(c,t)] e -> Ite <$> syn c <*> syn t <*> syn e 70 | Lang.Whn ((c,t):cs) e -> Ite <$> (syn c) <*> syn t <*> syn (Lang.Whn cs e) 71 | Lang.Swt m [(c,t)] e -> Ite <$> (syn $ Lang.Opr EQL m c) 72 | <*> (syn t) 73 | <*> (syn e) 74 | Lang.Swt m ((c,t):cs) e -> Ite <$> (syn $ Lang.Opr EQL m c) 75 | <*> (syn t) 76 | <*> (syn $ Lang.Swt m cs e) 77 | --Lang.Cse m ws adt cs t -> do 78 | 79 | 80 | Lang.Ref n i s -> do 81 | rs <- asks _refs 82 | case refLookup n i rs of 83 | Just m -> return $ Ref m (Cont $ shift s 0) 84 | _ -> throwError $ UndefinedReference n i s rs 85 | where 86 | syn = synTerm 87 | 88 | synBlock :: Map Name Lang.Term -> Syn (Map Name Name) 89 | synBlock ds = do 90 | i <- gets _idCount 91 | names <- sequence $ M.mapWithKey (\k v -> newName k) ds 92 | j <- gets _idCount 93 | let pre = M.mapKeys (\x -> names M.! x) ds 94 | terms <- withNames names $ traverse synTerm pre 95 | modify (\s -> s { _terms = M.union terms (_terms s) }) 96 | return names 97 | 98 | synModule :: [Lang.Declaration] -> Syn (Map Name Term) 99 | synModule ds = M.fromList . concat <$> (traverse synDecl ds) 100 | where 101 | synDecl :: Lang.Declaration -> Syn [(Name,Term)] 102 | synDecl d = case d of 103 | --Lang.Impt -> do 104 | Lang.Expr n t -> do 105 | t <- synTerm t 106 | return $ [(n,t)] 107 | Lang.Enum n ns -> case n of 108 | Just n -> do 109 | let str = buildString n 110 | let enumTyp = (n, Ann Typ (App (Ref "Enum" (Cont id)) str Eras)) 111 | let enumVal x = App (App (Ref "enum" (Cont id)) str Keep) (U64 x) Keep 112 | let enumVals = zip ns $ enumVal <$> [0..] 113 | return $ enumTyp : enumVals 114 | _ -> return $ zip ns $ U64 <$> [0..] 115 | 116 | --Lang.Data adt -> do 117 | 118 | buildString :: Text -> Term 119 | buildString txt = let 120 | str = T.unpack txt 121 | nums = (fromIntegral . ord) <$> str 122 | t = App (Ref "nil" (Cont id)) Wrd Eras 123 | f a b = App (App (App (Ref "cons" (Cont id)) Wrd Eras) (U64 a) Keep) b Keep 124 | in foldr f t nums 125 | 126 | refLookup :: Name -> Int -> Map Name [Name] -> Maybe Name 127 | refLookup n i refs = M.lookup n refs >>= (\xs -> xs !? i) 128 | where 129 | (!?) :: [a] -> Int -> Maybe a 130 | (!?) xs i = if i >= 0 && i < length xs then Just $ xs !! i else Nothing 131 | 132 | runSyn :: SynEnv -> SynState -> Syn a -> (Either SynError a, SynState, ()) 133 | runSyn env ste = (\x -> runRWS x env ste) . runExceptT 134 | 135 | defaultEnv = SynEnv M.empty 136 | defaultState = SynState 0 M.empty 137 | 138 | synDefault :: Syn a -> (Either SynError a, SynState, ()) 139 | synDefault s = runSyn defaultEnv defaultState s 140 | 141 | coreSyn :: SynEnv -> SynState -> [Lang.Declaration] -> Either SynError Core.Module 142 | coreSyn env ste ds = (\a -> Core.Module $ M.union a (_terms s)) <$> a 143 | where 144 | (a,s,()) = runSyn env ste (synModule ds) 145 | 146 | 147 | -------------------------------------------------------------------------------- /src/IEEE754.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module IEEE754 where 4 | 5 | import Numeric.IEEE 6 | import Numeric.Extras 7 | import Data.Word ( Word8, Word32, Word64 ) 8 | import System.IO.Unsafe (unsafeDupablePerformIO) 9 | import Foreign.Marshal.Alloc (alloca) 10 | import Foreign.Storable (peek, poke) 11 | import Foreign.Ptr (castPtr, Ptr) 12 | 13 | import qualified Data.ByteString as B 14 | 15 | import Data.Serialize 16 | import Data.Serialize.IEEE754 17 | 18 | import Data.Bits ((.&.), (.|.), xor, complement) 19 | import qualified Data.Bits as Bits 20 | 21 | wordToDouble :: Word64 -> Double 22 | wordToDouble w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word64) -> do 23 | poke ptr w 24 | peek (castPtr ptr) 25 | 26 | bytesToWord64 :: [Word8] -> Word64 27 | bytesToWord64 (b0:b1:b2:b3:b4:b5:b6:b7:_) = 28 | sh (f b0) 0 + sh (f b1) 8 + sh (f b2) 16 + sh (f b3) 24 + 29 | sh (f b4) 32 + sh (f b5) 40 + sh (f b6) 48 + sh (f b7) 56 30 | where 31 | f = fromIntegral 32 | sh = Bits.shift 33 | 34 | word64ToBytes :: Word64 -> [Word8] 35 | word64ToBytes n = 36 | f <$> [ n .&. 0xFF , (sh n (-8)) .&. 0xFF 37 | , (sh n (-16)) .&. 0xFF, (sh n (-24)) .&. 0xFF 38 | , (sh n (-32)) .&. 0xFF, (sh n (-40)) .&. 0xFF 39 | , (sh n (-48)) .&. 0xFF, (sh n (-56)) .&. 0xFF 40 | ] 41 | where 42 | f = fromIntegral 43 | sh = Bits.shift 44 | 45 | ftou :: Double -> Word64 46 | ftou n = bytesToWord64 $ B.unpack $ runPut $ putFloat64le n 47 | 48 | utof :: Word64 -> Double 49 | utof = wordToDouble 50 | -------------------------------------------------------------------------------- /src/Lang.hs: -------------------------------------------------------------------------------- 1 | module Lang where 2 | 3 | import Data.ByteString (ByteString) 4 | import qualified Data.ByteString as BS 5 | import Data.Map.Strict (Map) 6 | import qualified Data.Map.Strict as M 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import Data.Word 10 | 11 | import Core (Eras (..), Name, Op (..)) 12 | import qualified Core as Core 13 | 14 | -- Lang.Term 15 | -- The Formality frontend language which includes syntax sugar 16 | data Term 17 | = Var Int -- Variable 18 | | Typ -- Type type 19 | | All Name Term Eras Term -- Forall 20 | | Lam Name Term Eras Term -- Lambda 21 | | App Term Term Eras -- Application 22 | | Slf Name Term -- Self-type 23 | | New Term Term -- Self-type introduction 24 | | Use Term -- Self-type elimination 25 | | Let (Map Name Term) Term -- Recursive locally scoped definition 26 | | Whn [(Term, Term)] Term -- When-statement 27 | | Swt Term [(Term,Term)] Term -- Switch-statement 28 | | Cse Term [(Name, Term, Term)] ADT (Map Name Term) (Maybe Term) -- Case-statement 29 | | Rwt Term Term -- Rewrite 30 | | Wrd -- U64 Number type 31 | | Dbl -- F64 Number Type 32 | | U64 Word64 -- U64 number value 33 | | F64 Double -- F64 number value 34 | | Opr Op Term Term -- Binary operation 35 | | Ite Term Term Term -- If-then-else 36 | | Ann Term Term -- Type annotation 37 | | Log Term Term -- inline log 38 | | Hol Name -- type hole or metavariable 39 | | Ref Name Int Int -- reference to a definition 40 | | Str Text -- String value 41 | | Chr Char -- Character value 42 | | Nat Bool Int -- Natural number value 43 | | Bit Bool Integer -- Bitstring value 44 | | Par [Term] -- Pair value 45 | | PTy [Term] -- Pair type 46 | | Get Name Name Term Term -- Pair projection 47 | | Lst [Term] -- List value 48 | | Sig [(Maybe Name,Term)] Term -- Sigma type 49 | deriving (Eq, Show, Ord) 50 | 51 | -- Lang.Declaration 52 | -- Top-level definitions in a module 53 | data Declaration 54 | = Expr Name Term 55 | | Enum (Maybe Name) [Name] 56 | | Data ADT 57 | | Impt Text Text 58 | deriving (Eq, Show, Ord) 59 | 60 | type Param = (Name,Term) 61 | type Index = (Name,Term) 62 | data Ctor = Ctor 63 | { _ctorParams :: [Param] 64 | , _ctorType :: (Maybe Term) 65 | } deriving (Eq, Show, Ord) 66 | 67 | data ADT = ADT Name [Param] [Index] (M.Map Name Ctor) deriving (Eq, Show, Ord) 68 | 69 | -- a PreModule is an unsynthesizedunchecked collection of declarations 70 | type PreModule = [Declaration] 71 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser 2 | ( parseDefault 3 | , Parser.ParseError 4 | , module Lang 5 | , module Parser.Lang 6 | , module Parser.PreModule 7 | , module Parser.Types 8 | ) where 9 | 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import qualified Data.Text.IO as TIO 13 | import Data.Void 14 | 15 | import Text.Megaparsec hiding (State) 16 | 17 | import Control.Monad.Identity 18 | import Control.Monad.RWS.Lazy hiding (All) 19 | 20 | import Core (Eras (..), Name, Op (..)) 21 | import qualified Core as Core 22 | import Lang 23 | import Parser.Lang 24 | import Parser.PreModule 25 | import Parser.Types 26 | import Pretty 27 | 28 | -- top level parser with default env and state 29 | parseDefault :: Show a 30 | => Parser a 31 | -> Text 32 | -> Either (ParseErrorBundle Text Void) (a, ParseState, ()) 33 | parseDefault p s = 34 | runIdentity $ runParserT (runRWST p initParseEnv initParseState) "" s 35 | 36 | -- a useful testing function 37 | parserTest :: Show a => Parser a -> Text -> IO () 38 | parserTest p s = print $ parseDefault p s 39 | 40 | fileTest :: Show a => Parser a -> FilePath -> IO () 41 | fileTest p f = do 42 | txt <- TIO.readFile f 43 | print $ parseDefault p txt 44 | 45 | -- evals the term directly 46 | --evalTest :: Parser Term -> Text -> IO () 47 | --evalTest p s = do 48 | -- let Identity (Right (a,st,w)) = parseDefault p s 49 | -- print $ a 50 | -- print $ eval a Core.emptyModule 51 | 52 | type ParseError = ParseErrorBundle Text Void 53 | -------------------------------------------------------------------------------- /src/Parser/Lang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Parser.Lang where 3 | 4 | import Prelude hiding (log) 5 | 6 | import Text.Megaparsec hiding (State) 7 | import Text.Megaparsec.Char 8 | import qualified Text.Megaparsec.Char.Lexer as L 9 | 10 | import Data.Char 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Set (Set) 14 | import qualified Data.Set as Set 15 | import Data.Map.Strict (Map) 16 | import qualified Data.Map.Strict as M 17 | 18 | import Control.Monad.RWS.Lazy hiding (All) 19 | 20 | import Core (Eras (..), Name, Op (..)) 21 | import qualified Core as Core 22 | 23 | import Parser.Types 24 | import Lang 25 | 26 | sc :: Parser () 27 | sc = L.space space1 (L.skipLineComment "//" <|> L.skipLineComment "--") empty 28 | 29 | -- symbol followed by spaces 30 | sym :: Text -> Parser Text 31 | sym t = L.symbol sc t 32 | 33 | -- symbol not followed by spaces 34 | lit :: Text -> Parser Text 35 | lit t = string t 36 | 37 | name :: Parser Text 38 | name = do 39 | us <- many (lit "_") 40 | n <- if us == [] then letterChar else alphaNumChar 41 | ns <- many (alphaNumChar <|> oneOf nameSymbol) 42 | let nam = T.concat [T.concat us, T.pack (n : ns)] 43 | if nam `elem` reservedWords then fail "reservedWord" else return nam 44 | where 45 | nameSymbol = "_.-@/'" :: [Char] 46 | reservedWords = ["let", "T", "case", "with"] :: [Text] 47 | 48 | -- resolves if a name is a variable or reference 49 | refVar :: Parser Term 50 | refVar = do 51 | ctx <- asks _binders 52 | is <- optional (some (lit "^")) 53 | n <- name 54 | let carets = maybe 0 id (length <$> is) 55 | return $ go ctx carets 0 0 n 56 | where 57 | go(x:xs) cs varIndex refCount n 58 | | VarB m <- x, n == m, cs == 0 = Var varIndex 59 | | VarB m <- x, n == m = go xs (cs - 1) (varIndex + 1) refCount n 60 | | VarB m <- x, n /= m = go xs cs (varIndex + 1) refCount n 61 | | RefB m <- x, n == m, cs == 0 = Ref n refCount varIndex 62 | | RefB m <- x, n == m = go xs (cs - 1) varIndex (refCount + 1) n 63 | | otherwise = go xs cs varIndex refCount n 64 | go [] cs varIndex refCount n = Ref n (cs + refCount) varIndex 65 | 66 | -- numeric type 67 | dbl :: Parser Term 68 | dbl = lit "Double" >> return Dbl 69 | 70 | wrd :: Parser Term 71 | wrd = lit "Word" >> return Wrd 72 | 73 | -- numeric U64 value 74 | u64 :: Parser Term 75 | u64 = do 76 | v <- choice 77 | [ lit "0x" >> L.hexadecimal 78 | , lit "0o" >> L.octal 79 | , lit "0b" >> L.binary 80 | , L.decimal 81 | ] 82 | when ((v :: Integer) >= 2^64) (fail "word too big") 83 | return $ U64 (fromIntegral v) 84 | 85 | f64 :: Parser Term 86 | f64 = F64 <$> L.signed (pure ()) L.float 87 | 88 | bit :: Parser Term 89 | bit = do 90 | v <- choice 91 | [ lit "0x" >> L.hexadecimal 92 | , lit "0o" >> L.octal 93 | , lit "0d" >> L.decimal 94 | , L.binary 95 | ] 96 | t <- (lit "b" >> return False) <|> (lit "B" >> return True) 97 | return $ Bit t v 98 | 99 | nat :: Parser Term 100 | nat = do 101 | v <- choice 102 | [ lit "0x" >> L.hexadecimal 103 | , lit "0o" >> L.octal 104 | , lit "0b" >> L.binary 105 | , L.decimal 106 | ] 107 | t <- (lit "n" >> return False) <|> (lit "N" >> return True) 108 | return $ Nat t v 109 | 110 | -- The type "Type" 111 | typ :: Parser Term 112 | typ = lit "Type" >> return Typ 113 | 114 | -- forall or lambda 115 | allLam :: Parser Term 116 | allLam = do 117 | bs <- binds True "(" ")" <* sc 118 | ctor <- (sym "->" >> return All) <|> (sym "=>" >> return Lam) 119 | body <- binders ((\(x,y,z) -> VarB x) <$> bs) term 120 | return $ foldr (\(n,t,e) x -> ctor n t e x) body bs 121 | 122 | -- binders in a forall or lambda 123 | binds :: Bool -> Text -> Text -> Parser [(Name, Term, Eras)] 124 | binds erasable start end = sym start >> go 125 | where 126 | go = (sc >> lit end >> return []) <|> next 127 | 128 | next :: Parser [(Name,Term,Eras)] 129 | next = do 130 | (b, t) <- choice 131 | [ ("_",) <$> (sym ":" >> term <* sc) 132 | , (,) <$> ((try $ lit "_") <|> name) 133 | <*> ((sc >> (sym ":" >> term) <* sc) <|> newHole) 134 | ] 135 | e <- choice 136 | [ (sym ",") >> return Keep 137 | , if erasable then (sym ";") >> return Eras else fail "" 138 | , lookAhead (try $ sc >> lit end) >> return Keep 139 | ] 140 | bs <- binders [VarB b] $ go 141 | return $ (b,t,e) : bs 142 | 143 | -- get a hole with a unique name 144 | newHole :: Parser Term 145 | newHole = do 146 | h <- gets _holeCount 147 | modify (\s -> s { _holeCount = (_holeCount s) + 1 }) 148 | return $ Hol $ T.pack ("#" ++ show h) 149 | 150 | -- a self-type 151 | slf :: Parser Term 152 | slf = do 153 | n <- sym "${" >> name <* sc <* sym "}" 154 | Slf n <$> (binders [VarB n] term) 155 | 156 | -- a self-type introduction 157 | new :: Parser Term 158 | new = New <$> (sym "new(" >> term <* sc <* sym ")") <*> term 159 | 160 | -- a self-type elimination 161 | use :: Parser Term 162 | use = Use <$> (sym "use(" >> term <* sc <* sym ")") 163 | 164 | -- an inline typed log 165 | log :: Parser Term 166 | log = Log <$> (sym "log(" >> term <* sc <* sym ")") <*> term 167 | 168 | -- if-then-else 169 | ite :: Parser Term 170 | ite = Ite <$> (sym "if" >> term <* sc) 171 | <*> (sym "then" >> term <* sc) 172 | <*> (sym "else" >> term <* sc) 173 | 174 | -- a programmer defined hole 175 | hol :: Parser Term 176 | hol = sym "?" >> (Hol <$> name <|> newHole) 177 | 178 | -- function style application 179 | fun :: Term -> Parser Term 180 | fun f = foldl (\t (a,e) -> App t a e) f <$> (concat <$> some args) 181 | where 182 | args = sym "(" >> go 183 | go = (sc >> lit ")" >> return []) <|> next 184 | next = do (a,e) <- holeArg <|> termArg; as <- go; return $ (a,e) : as 185 | holeArg = sym "_" >> (\x -> (x,Eras)) <$> newHole 186 | termArg = do 187 | t <- term 188 | e <- choice 189 | [ sym "," >> return Keep 190 | , sym ";" >> return Eras 191 | , lookAhead (try $ sc >> lit ")") >> return Keep 192 | ] 193 | return (t,e) 194 | 195 | -- an operator name 196 | opName :: Parser Text 197 | opName = do 198 | n <- oneOf opInitSymbol 199 | case elem n opSingleSymbol of 200 | True -> T.pack . (n:) <$> many (oneOf opSymbol) 201 | False -> T.pack . (n:) <$> some (oneOf opSymbol) 202 | where 203 | opInitSymbol = "!$%&*+./\\<=>^|~-" :: [Char] 204 | opSingleSymbol = "!$%&*+./\\<>^|~-" :: [Char] 205 | opSymbol = "!#$%&*+./\\<=>?@^|~-" :: [Char] 206 | 207 | -- binary symbolic operator 208 | opr :: Term -> Parser Term 209 | opr x = do 210 | sc 211 | op <- opName 212 | when (op `elem` reservedSymbols) (fail "reservedWord") 213 | sc 214 | y <- term 215 | case op of 216 | "->" -> return $ All "_" x Keep y 217 | "+" -> return $ Opr ADD x y 218 | "-" -> return $ Opr SUB x y 219 | "*" -> return $ Opr MUL x y 220 | "\\" -> return $ Opr DIV x y 221 | "/" -> return $ Opr DIV x y 222 | "%" -> return $ Opr MOD x y 223 | "**" -> return $ Opr POW x y 224 | "&&" -> return $ Opr AND x y 225 | "||" -> return $ Opr BOR x y 226 | "^" -> return $ Opr XOR x y 227 | "~" -> return $ Opr NOT x y 228 | ">" -> return $ Opr GTH x y 229 | "<" -> return $ Opr LTH x y 230 | ">>>" -> return $ Opr SHR x y 231 | "<<" -> return $ Opr SHL x y 232 | "===" -> return $ Opr EQL x y 233 | -- f -> return $ App (App (Ref f 0 0) x Keep) y Keep 234 | where 235 | reservedSymbols = ["|", "=>"] 236 | 237 | ann :: Term -> Parser Term 238 | ann x = (\y -> Ann y x) <$> (sc >> sym "::" >> (rwt <|> term)) 239 | where 240 | rwt = Rwt <$> (sym "rewrite" >> term <* sc) <*> (sym "with" >> term) 241 | 242 | -- case expression 243 | -- 244 | -- case x as y 245 | -- with c : P 246 | -- | foo => 1 247 | -- | bar => 2 248 | -- : Q 249 | -- 250 | 251 | 252 | cse :: Parser Term 253 | cse = do 254 | sym "case" 255 | (as,m) <- namedTerm <* sc 256 | ws <- sepBy' wit sc <* sc 257 | (adt,cs,t) <- cases as <|> empty 258 | return $ Cse m ws adt cs t 259 | where 260 | wit :: Parser (Name, Term, Term) 261 | wit = do 262 | (n,m) <- sym "with" >> namedTerm 263 | t <- (sc >> sym ":" >> term) <|> newHole 264 | return (n,m,t) 265 | 266 | empty :: Parser (ADT, Map Name Term, Maybe Term) 267 | empty = do 268 | t <- sym ":" >> term 269 | let e = ADT "Empty" [] [] M.empty 270 | return (e,M.empty,Just t) 271 | 272 | cases :: Name -> Parser (ADT, Map Name Term, Maybe Term) 273 | cases as = do 274 | n <- lookAhead (sym "|" >> name) 275 | acs <- gets _adtCtors 276 | case acs M.!? n of 277 | Nothing -> fail "can't find ADT" 278 | Just a@(ADT _ ps _ m) -> do 279 | cs <- go as ps m [] 280 | ty <- optional $ try $ (sc >> sym ":" >> term) 281 | return $ (a, cs, ty) 282 | 283 | go :: Name -> [Param] -> M.Map Name Ctor -> [(Name,Term)] -> Parser (Map Name Term) 284 | go as ps m cs = do 285 | n <- sym "|" >> name <* sc 286 | when (M.notMember n m) (fail "constructor not in ADT") 287 | let adtBinds = VarB . fst <$> ps 288 | let ctorParams = _ctorParams $ m M.! n 289 | let ctorBinds = (\(a,b) -> VarB $ T.concat [as, ".", a]) <$> ctorParams 290 | t <- binders (adtBinds ++ ctorBinds) $ sym "=>" >> term 291 | let m' = M.delete n m 292 | if m' == M.empty 293 | then return $ M.fromList ((n,t):cs) 294 | else sc >> go as ps m' ((n,t):cs) 295 | 296 | namedTerm :: Parser (Name,Term) 297 | namedTerm = do 298 | n <- optional $ try $ lookAhead name 299 | m <- term 300 | case (n,m) of 301 | (Just n, Ref _ _ _) -> go n m 302 | (Just n, Var _) -> go n m 303 | (_, _) -> do 304 | n' <- sc >> sym "as" >> name 305 | return (n',m) 306 | where 307 | go n m = do 308 | n' <- maybe n id <$> (optional $ try $ sc >> sym "as" >> name) 309 | return $ (n',m) 310 | 311 | 312 | 313 | 314 | 315 | -- Megaparsec sepBy is eager, we need non-eager sep 316 | 317 | sepBy1' p sep = (:) <$> p <*> many (try $ sep >> p) 318 | sepBy' p sep = sepBy1' p sep <|> pure [] 319 | -- Parses at least 2 320 | sepBy2' p sep = (:) <$> (p <* sep) <*> sepBy1' p sep 321 | 322 | whn :: Parser Term 323 | whn = Whn <$> (sym "when" >> some w <* sc) <*> (sym "else" >> term) 324 | where 325 | w = do sym "|"; c <- term; sc; sym "=>"; t <- term; sc; return (c,t) 326 | 327 | swt :: Parser Term 328 | swt = Swt <$> (sym "switch" >> term <* sc) <*> (some w <* sc) <*> (sym "else" >> term) 329 | where 330 | w = do sym "|"; c <- term; sc; sym "=>"; t <- term; sc; return (c,t) 331 | 332 | def :: Parser a -> Parser (Name, Term) 333 | def x = do 334 | n <- name 335 | bs <- (optional $ binds True "(" ")") 336 | sc 337 | let ns = maybe [] (fmap (\(a,b,c) -> VarB a)) bs 338 | t <- optional (sym ":" >> binders ns term <* sc) 339 | x 340 | d <- binders ns term 341 | let x = case (bs, t) of 342 | (Nothing, Nothing) -> d 343 | (Nothing, Just t) -> Ann t d 344 | (Just bs, Nothing) -> foldr (\(n,t,e) x -> Lam n t e x) d bs 345 | (Just bs, Just t) -> Ann 346 | (foldr (\(n,t,e) x -> All n t e x) t bs) 347 | (foldr (\(n,t,e) x -> Lam n t e x) d bs) 348 | return $ (n,x) 349 | 350 | let_ :: Parser Term 351 | let_ = do 352 | sym "let" 353 | ds <- (sym "(" >> lets) <|> (pure <$> (def (sym "=") <* sepr)) 354 | sc 355 | t <- binders (RefB . fst <$> ds) $ term 356 | return $ Let (M.fromList ds) t 357 | where 358 | sepr :: Parser (Maybe Text) 359 | sepr = optional $ try $ (sc >> lit ";") 360 | 361 | lets :: Parser [(Name, Term)] 362 | lets = (lit ")" >> sepr >> return []) <|> next 363 | 364 | next :: Parser [(Name, Term)] 365 | next = do 366 | (n,t) <- def (sym "=") <* (sepr >> sc) 367 | ns <- block n $ lets 368 | return $ (n,t) : ns 369 | 370 | get_ :: Parser Term 371 | get_ = do 372 | sym "get" >> (sym "[" <|> sym "#[") 373 | x <- name <* sc <* sym "," 374 | y <- name <* sc <* sym "]" <* sym "=" 375 | t <- term <* sc <* optional (sym ";") 376 | b <- binders [RefB x, RefB y] term 377 | return $ Get x y t b 378 | 379 | str :: Parser Term 380 | str = do 381 | char '"' 382 | cs <- many $ choice 383 | [ pure <$> noneOf ("\\\"" :: String) 384 | , lit "\\&" >> return [] 385 | , pure <$> esc 386 | ] 387 | char '"' 388 | return $ Str . T.pack . concat $ cs 389 | 390 | chr_ :: Parser Term 391 | chr_ = Chr <$> (char '\'' >> (noneOf ("\\\'" :: String) <|> esc) <* char '\'') 392 | 393 | esc :: Parser Char 394 | esc = do 395 | char '\\' 396 | choice 397 | [ lit "\\" >> return '\\' 398 | , lit "\"" >> return '"' 399 | , lit "x" >> chr <$> L.hexadecimal 400 | , lit "o" >> chr <$> L.octal 401 | , lit "n" >> return '\n' 402 | , lit "r" >> return '\r' 403 | , lit "v" >> return '\v' 404 | , lit "b" >> return '\b' 405 | , lit "f" >> return '\f' 406 | , lit "ACK" >> return '\ACK' 407 | , lit "BEL" >> return '\BEL' 408 | , lit "BS" >> return '\BS' 409 | , lit "CR" >> return '\CR' 410 | , lit "DEL" >> return '\DEL' 411 | , lit "DC1" >> return '\DC1' 412 | , lit "DC2" >> return '\DC2' 413 | , lit "DC3" >> return '\DC3' 414 | , lit "DC4" >> return '\DC4' 415 | , lit "DLE" >> return '\DLE' 416 | , lit "ENQ" >> return '\ENQ' 417 | , lit "EOT" >> return '\EOT' 418 | , lit "ESC" >> return '\ESC' 419 | , lit "ETX" >> return '\ETX' 420 | , lit "ETB" >> return '\ETB' 421 | , lit "EM" >> return '\EM' 422 | , lit "FS" >> return '\FS' 423 | , lit "FF" >> return '\FF' 424 | , lit "GS" >> return '\GS' 425 | , lit "HT" >> return '\HT' 426 | , lit "LF" >> return '\LF' 427 | , lit "NUL" >> return '\NUL' 428 | , lit "NAK" >> return '\NAK' 429 | , lit "RS" >> return '\RS' 430 | , lit "SOH" >> return '\SOH' 431 | , lit "STX" >> return '\STX' 432 | , lit "SUB" >> return '\SUB' 433 | , lit "SYN" >> return '\SYN' 434 | , lit "SI" >> return '\SI' 435 | , lit "SO" >> return '\SO' 436 | , lit "SP" >> return '\SP' 437 | , lit "US" >> return '\US' 438 | , lit "VT" >> return '\VT' 439 | , lit "^@" >> return '\0' 440 | , lit "^[" >> return '\ESC' 441 | , lit "^\\" >> return '\FS' 442 | , lit "^]" >> return '\GS' 443 | , lit "^^" >> return '\RS' 444 | , lit "^_" >> return '\US' 445 | , (\ c -> chr $ (ord c) - 64) <$> (lit "^" >> oneOf ['A'..'Z']) 446 | , chr <$> L.decimal 447 | ] 448 | 449 | lst :: Parser Term 450 | lst = Lst <$> choice 451 | [ sym "[" >> sepBy' term (sc >> sym ",") <* (sc >> lit "]") 452 | , sym "{" >> sepBy' keyVal (sc >> sym ",") <* (sc >> lit "}") 453 | ] 454 | where 455 | keyVal = do p <- term; sc; sym ":"; q <- term; return $ Par [p,q] 456 | 457 | -- pair value 458 | par :: Parser Term 459 | par = Par <$> choice 460 | [ sym "(" >> sepBy2' term (sc >> sym ",") <* (sc >> lit ")") 461 | , sym "#[" >> sepBy2' term (sc >> sym ",") <* (sc >> lit "]") 462 | ] 463 | 464 | -- pair type 465 | pTy :: Parser Term 466 | pTy = PTy <$> choice 467 | [ sym "#(" >> sepBy2' term (sc >> sym ",") <* (sc >> lit ")") 468 | , sym "#{" >> sepBy2' term (sc >> sym ",") <* (sc >> lit "}") 469 | ] 470 | 471 | -- Sigma type 472 | sig :: Parser Term 473 | sig = do 474 | sym "[" 475 | ns <- sepBy' p (sc >> sym ",") 476 | x <- sym "," >> term 477 | sym "]" 478 | return $ Sig ns x 479 | where 480 | p = (,) <$> (optional $ name <* sc) <*> term 481 | 482 | term :: Parser Term 483 | term = do 484 | t <- term' <|> group 485 | t' <- try $ fun t <|> return t 486 | choice 487 | [ try $ ann t' 488 | , try $ opr t' 489 | , return t' 490 | ] 491 | where 492 | group :: Parser Term 493 | group = sym "(" >> foldApp <$> (sc >> sepEndBy1 term sc) <* lit ")" 494 | foldApp = foldl1 (\x y -> App x y Keep) 495 | 496 | term' :: Parser Term 497 | term' = choice 498 | [ try $ allLam 499 | , try $ let_ 500 | , try $ get_ 501 | , try $ typ 502 | , try $ dbl 503 | , try $ wrd 504 | , try $ str 505 | , try $ chr_ 506 | , try $ lst 507 | , try $ slf 508 | , try $ new 509 | , try $ log 510 | , try $ use 511 | , try $ ite 512 | , try $ hol 513 | , try $ bit 514 | , try $ nat 515 | , try $ f64 516 | , try $ u64 517 | , try $ whn 518 | , try $ cse 519 | , try $ swt 520 | , try $ refVar 521 | , try $ lst 522 | , try $ par 523 | , try $ pTy 524 | ] 525 | -------------------------------------------------------------------------------- /src/Parser/PreModule.hs: -------------------------------------------------------------------------------- 1 | module Parser.PreModule where 2 | 3 | import Text.Megaparsec hiding (State) 4 | import Text.Megaparsec.Char 5 | import qualified Text.Megaparsec.Char.Lexer as L 6 | 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as M 11 | 12 | import Data.Set (Set) 13 | import qualified Data.Set as Set 14 | 15 | import Control.Monad.RWS.Lazy hiding (All) 16 | 17 | import Lang 18 | import Core (Name) 19 | import Parser.Types 20 | import Parser.Lang 21 | 22 | declaration :: Parser Declaration 23 | declaration = choice 24 | [ try $ enum 25 | , try $ Data <$> datatype 26 | , try $ import_ 27 | , definition 28 | ] 29 | 30 | definition :: Parser Declaration 31 | definition = do 32 | (n,t) <- def (optional $ sym ";") 33 | names n 34 | return $ Expr n t 35 | 36 | enum :: Parser Declaration 37 | enum = do 38 | sym "enum" 39 | n <- try $ optional (name <* sc) 40 | Enum n <$> some e 41 | where 42 | e = do sym "|"; n <- name; names n; sc; return n 43 | 44 | datatype :: Parser ADT 45 | datatype = do 46 | n <- sym "T" >> name 47 | names n 48 | ps <- optional' $ binds False "{" "}" 49 | sc 50 | is <- optional' $ binders ((\(x,y,z) -> VarB x) <$> ps) (binds False "(" ")") 51 | sc 52 | cs <- binders ((\(x,y,z) -> VarB x) <$> ps) (many (sym "|" >> ctor)) 53 | return $ ADT n (f <$> ps) (f <$> is) (M.fromList cs) 54 | where 55 | f (a,b,c) = (a,b) 56 | 57 | optional' :: Parser [a] -> Parser [a] 58 | optional' p = maybe [] id <$> (optional p) 59 | 60 | ctor :: Parser (Name, Ctor) 61 | ctor = do 62 | n <- name 63 | names n 64 | ps <- optional' (binds True "(" ")") <* sc 65 | ix <- optional (sym ":" >> binders ((\(x,y,z) -> VarB x) <$> ps) term <* sc) 66 | return $ (n, Ctor (f <$> ps) ix) 67 | 68 | import_ :: Parser Declaration 69 | import_ = do 70 | sym "import" 71 | n <- name 72 | h <- maybe "" id <$> optional (sym "#" >> some (satisfy isFileID)) 73 | return $ Impt n (T.pack h) 74 | where 75 | isFileID x = elem x (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']) 76 | 77 | seekADT :: Parser [ADT] 78 | seekADT = lookAhead $ sc >> many (try go) 79 | where 80 | go :: Parser ADT 81 | go = datatype <|> (takeP Nothing 1 >> sc >> go) 82 | 83 | premodule :: Parser [Declaration] 84 | premodule = do 85 | adts <- seekADT 86 | sequence $ adtCtors <$> adts 87 | sc >> decls 88 | where 89 | decls :: Parser [Declaration] 90 | decls = (sc >> eof >> return []) <|> next 91 | 92 | next :: Parser [Declaration] 93 | next = do 94 | d <- declaration <* sc 95 | case d of 96 | Expr n t -> do 97 | ds <- decls 98 | return $ d : ds 99 | Enum _ _ -> do 100 | ds <- decls 101 | return $ d : ds 102 | Data (ADT _ _ _ cs) -> do 103 | let cns = M.keys cs 104 | ds <- decls 105 | return $ d : ds 106 | Impt _ _ -> do 107 | ds <- decls 108 | return $ d : ds 109 | 110 | -------------------------------------------------------------------------------- /src/Parser/Types.hs: -------------------------------------------------------------------------------- 1 | module Parser.Types where 2 | 3 | import Data.Set (Set) 4 | import qualified Data.Set as Set 5 | import Data.Text (Text) 6 | import qualified Data.Text as T 7 | import Data.Void 8 | import Data.Map.Strict (Map) 9 | import qualified Data.Map.Strict as M 10 | 11 | import Control.Monad (void) 12 | import Control.Monad.Identity 13 | import Control.Monad.RWS.Lazy hiding (All) 14 | 15 | import Text.Megaparsec hiding (State) 16 | import Text.Megaparsec.Char 17 | import qualified Text.Megaparsec.Char.Lexer as L 18 | 19 | import Core (Eras (..), Name, Op (..)) 20 | import qualified Core as Core 21 | 22 | import qualified Lang as Lang 23 | 24 | -- binders can bind variables (deBruijn) or references 25 | data Binder = VarB Name | RefB Name deriving (Eq, Show) 26 | 27 | data ParseState = ParseState 28 | { _holeCount :: Int -- for generating unique metavariable names 29 | , _names :: Set Name -- top level names 30 | , _adtCtors :: Map Name Lang.ADT 31 | } deriving Show 32 | 33 | data ParseEnv = ParseEnv 34 | { _binders :: [Binder] -- binding contexts from lets, lambdas or foralls 35 | , _block :: Set Name -- set of names in local `let` block 36 | } deriving Show 37 | 38 | type Parser = RWST ParseEnv () ParseState (ParsecT Void Text Identity) 39 | 40 | -- add top level name to state 41 | names :: Name -> Parser () 42 | names n = do 43 | ds <- gets _names 44 | when (Set.member n reservedNames) (fail "reserved Name") 45 | when (Set.member n ds) (fail "attempted to redefine a name") 46 | modify (\s -> s {_names = Set.union (Set.singleton n) ds}) 47 | where 48 | reservedNames = 49 | Set.fromList ["T", "enum", "case", "switch", "let", "when"] 50 | 51 | -- add a list of binders to the context 52 | binders :: [Binder] -> Parser a -> Parser a 53 | binders bs p = local (\e -> e { _binders = (reverse bs) ++ _binders e }) p 54 | 55 | -- add names to current mutual recursion block 56 | block :: Name -> Parser a -> Parser a 57 | block n p = do 58 | ds <- asks _block 59 | when (Set.member n ds) (fail "attempted to redefine a name") 60 | local (\e -> e { _block = Set.union (Set.singleton n) ds}) p 61 | 62 | adtCtors :: Lang.ADT -> Parser () 63 | adtCtors a@(Lang.ADT _ _ _ m) = do 64 | cs <- gets _adtCtors 65 | modify (\s -> s {_adtCtors = M.union (const a <$> m) cs }) 66 | 67 | -- a parser is a Reader-Writer-State monad transformer wrapped over a ParsecT 68 | -- TODO : Custom error messages 69 | 70 | initParseState = ParseState 0 Set.empty M.empty 71 | initParseEnv = ParseEnv [] Set.empty 72 | 73 | -------------------------------------------------------------------------------- /src/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Pretty where 2 | 3 | import Data.Text (Text) 4 | import qualified Data.Text as T 5 | 6 | import Core 7 | 8 | -- pretty-printing 9 | pretty :: Term -> Text 10 | pretty t = go t [] 11 | where 12 | cat = T.concat 13 | 14 | showOp ADD = " + " 15 | showOp SUB = " - " 16 | showOp MUL = " * " 17 | showOp DIV = " / " 18 | showOp MOD = " % " 19 | 20 | go :: Term -> [Text] -> Text 21 | go t s = case t of 22 | Var i -> if i < length s then s !! i else cat ["^", T.pack $ show i] 23 | Typ -> "Type" 24 | All n h Eras b -> cat ["(", n, " : ", go h s, ";) -> ", go b (n : s)] 25 | All n h e b -> cat ["(", n, " : ", go h s, ") -> ", go b (n : s)] 26 | Lam n h Eras b -> cat ["(", n, " : ", go h s, ";) => ", go b (n : s)] 27 | Lam n h e b -> cat ["(", n, " : ", go h s, ") => ", go b (n : s)] 28 | App f@(Lam _ _ _ _) a Eras -> 29 | cat ["((", go f s, ") " , go a s, ";)"] 30 | App f@(Lam _ _ _ _) a e -> 31 | cat ["((", go f s, ") " , go a s, ")"] 32 | App f a Eras -> cat ["(", go f s, " " , go a s, ";)"] 33 | App f a e -> cat ["(", go f s, " ", go a s, ")"] 34 | -- Let bs b -> 35 | -- let bs' = (\(n,t) -> cat [n, " = ", go t s, ";"]) <$> bs in 36 | -- cat (["let "] ++ bs' ++ [go b s]) 37 | Slf n t -> cat ["${", n, "}", go t s] 38 | New t x -> cat ["new(", go t s, ")", go x s] 39 | Use x -> cat ["use(", go x s, ")"] 40 | -- Num -> "Number" 41 | --Val i -> T.pack $ show i 42 | Op2 o a b -> cat [go a s, showOp o, go b s] 43 | Op1 o a b -> cat [T.pack $ show a, showOp o, go b s] 44 | Ite c t f -> cat ["if ", go c s, " then ", go t s, " else ", go f s] 45 | Ann x y -> cat [go y s, " :: ", go x s] 46 | Log x y -> cat ["log(", go x s, "); ", go y s] 47 | Hol n -> cat ["?", n] 48 | Ref n f -> n 49 | 50 | -------------------------------------------------------------------------------- /src/Runtime/Net.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | module Runtime.Net where 3 | 4 | import Control.Monad.State.Strict 5 | import Data.List (intercalate) 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | import qualified Data.Vector.Unboxed as V 9 | import Data.Word 10 | import Data.Bits 11 | import Numeric (showHex) 12 | import Text.Printf (PrintfArg, printf) 13 | 14 | type Node = (Word64, Word64, Word64, Word64) 15 | 16 | nodeInfo :: Node -> Word64 17 | nodeInfo (i,p,l,r) = i 18 | 19 | mainPort :: Node -> Word64 20 | mainPort (i,m,l,r) = m 21 | 22 | leftPort :: Node -> Word64 23 | leftPort (i,m,l,r) = l 24 | 25 | rightPort :: Node -> Word64 26 | rightPort (i,m,l,r) = r 27 | 28 | showNode :: (Integer,Node) -> String 29 | showNode (x,(i,m,l,r)) = 30 | case readInfoBits i of 31 | (Info True Con _ _ _ _ _ _) -> show x ++ ":FREE_" 32 | (Info True Dup _ lS _ _ _ _) -> show x ++ ":SET_" ++ showPort lS l 33 | (Info False n mS lS rS m1 m2 m3) -> 34 | if (m1 == 0 && m2 == 0 && m3 == 0) 35 | then concat [show x, ":",show n, "_", showPort mS m, showPort lS l, showPort rS r] 36 | else concat [ show x, ":",show n, "_", showPort mS m, showPort lS l, showPort rS r 37 | , showHex m1 "", showHex m2 "", showHex m3 "" 38 | ] 39 | 40 | showPort :: Slot -> Word64 -> String 41 | showPort M n = "M" ++ showHex n "" 42 | showPort L n = "L" ++ showHex n "" 43 | showPort R n = "R" ++ showHex n "" 44 | 45 | i64_truncate :: Word64 -> Word32 46 | i64_truncate n = (fromIntegral n) .&. 0xFFFFFFFF 47 | 48 | data Slot 49 | = M -- Main 50 | | L -- Left 51 | | R -- Right 52 | deriving (Enum, Show, Bounded, Eq, Ord) 53 | 54 | data NType = Con | Dup deriving (Enum, Bounded, Eq, Show) 55 | 56 | data Info = Info { 57 | isFree :: Bool 58 | , ntype :: NType 59 | , mainSlot :: Slot 60 | , leftSlot :: Slot 61 | , rightSlot :: Slot 62 | , meta1 :: Word8 63 | , meta2 :: Word16 64 | , meta3 :: Word32 65 | } deriving Eq 66 | 67 | infoBits :: Info -> Word64 68 | infoBits (Info f n mS lS rS m1 m2 m3) = fromIntegral $ 69 | (fromEnum f) + 70 | (fromEnum n) `shiftL` 1 + 71 | (fromEnum mS) `shiftL` 2 + 72 | (fromEnum lS) `shiftL` 4 + 73 | (fromEnum rS) `shiftL` 6 + 74 | (fromEnum m1) `shiftL` 8 + 75 | (fromEnum m2) `shiftL` 16 + 76 | (fromEnum m3) `shiftL` 32 77 | 78 | readInfoBits :: Word64 -> Info 79 | readInfoBits x = let n = (fromIntegral x) in Info 80 | (toEnum $ n .&. 0x1) 81 | (toEnum $ (n `shiftR` 1) .&. 0x1) 82 | (toEnum $ (n `shiftR` 2) .&. 0x3) 83 | (toEnum $ (n `shiftR` 4) .&. 0x3) 84 | (toEnum $ (n `shiftR` 6) .&. 0x3) 85 | (toEnum $ (n `shiftR` 8) .&. 0xFF) 86 | (toEnum $ (n `shiftR` 16) .&. 0xFFFF) 87 | (toEnum $ (n `shiftR` 32) .&. 0xFFFFFFFF) 88 | 89 | instance Enum Info where 90 | toEnum = readInfoBits . fromIntegral 91 | fromEnum = fromIntegral . infoBits 92 | 93 | instance Show Info where 94 | show (Info f n m l r m1 m2 m3) 95 | | f = "F" 96 | | m1 == 0 && m2 == 0 && m3 == 0 = concat [show n, ":", show m, show l, show r] 97 | | otherwise = concat 98 | [ show n, ":" , show m, show l, show r 99 | , showHex m1 "", showHex m2 "", showHex m3 "" 100 | ] 101 | 102 | printBits :: (PrintfArg a) => a -> IO () 103 | printBits n = do 104 | putStrLn $ printf "%08b" n 105 | 106 | mkNode :: NType -> Slot -> Word64 -> Slot -> Word64 -> Slot -> Word64 -> Node 107 | mkNode n mS m lS l rS r = ((infoBits (Info False n mS lS rS 0 0 0)),m,l,r) 108 | 109 | mkFree :: Word64 -> Node 110 | mkFree i = ((infoBits (Info True Con M L R 0 0 0)),i,i,i) 111 | 112 | mkSet :: Slot -> Word64 -> Node 113 | mkSet s n = ((infoBits (Info True Dup L s L 0 0 0)),0,n,0) 114 | 115 | getNType :: Node -> NType 116 | getNType (i,_,_,_) = ntype $ readInfoBits i 117 | 118 | 119 | data Net = 120 | Net { nodes :: V.Vector Node 121 | , freed :: [Word64] 122 | , redex :: [(Word64,Word64)] 123 | } deriving (Eq, Show) 124 | 125 | --instance Show Net where 126 | -- show (Net ws fs rs) = concat $ 127 | -- [ intercalate "\n" (showNode <$> (zip [0..] (V.toList ws))) 128 | -- , "\n" 129 | -- , "FREE:", show fs 130 | -- , "\n" 131 | -- , "REDEX:", show rs 132 | -- ] 133 | 134 | testNodes :: [Node] 135 | testNodes = 136 | [ mkNode Con M 0 L 1 L 0 137 | -- , Node (labelBits (Label True Con M R R)) 0 1 1 138 | , mkNode Con M 0 R 1 R 1 139 | ] 140 | 141 | testWords :: V.Vector Node 142 | testWords = V.fromList testNodes 143 | 144 | findRedexes :: V.Vector Node -> [(Word64, Word64)] 145 | findRedexes vs = Set.toList $ V.ifoldr insertRedex Set.empty vs 146 | where 147 | insertRedex :: Int -> Node -> Set (Word64, Word64) -> Set (Word64, Word64) 148 | insertRedex i (b,m,l,r) set 149 | | mainSlot (readInfoBits b) == M 150 | && mainSlot (readInfoBits b') == M 151 | && i == fromIntegral m' 152 | && not (Set.member (m,m') set) 153 | = Set.insert (m',m) set 154 | | otherwise = set 155 | where 156 | (b',m',l',r') = vs V.! (fromIntegral m) 157 | 158 | makeNet :: [Node] -> Net 159 | makeNet nodes = let vs = V.fromList nodes in Net vs [] (findRedexes vs) 160 | 161 | testNet :: Net 162 | testNet = makeNet testNodes 163 | 164 | allocNode :: NType -> State Net Word64 165 | allocNode n = do 166 | (Net vs fs rs) <- get 167 | let node i = (infoBits (Info False n M L R 0 0 0), i, i, i) 168 | case fs of 169 | [] -> do 170 | let i = fromIntegral (V.length vs) 171 | modify (\n -> n { nodes = vs `V.snoc` (node i)}) 172 | return i 173 | (f:fs) -> do 174 | modify (\n -> n { nodes = vs V.// [(fromIntegral f,node f)], freed = fs}) 175 | return f 176 | 177 | --isFreed :: Word64 -> State Net Bool 178 | --isFreed i = do 179 | -- n <- (\x -> x V.! (fromIntegral i)) <$> gets nodes 180 | -- return $ getNType n == Fre 181 | 182 | freeNode :: Word64 -> State Net () 183 | freeNode i = modify (\n -> 184 | n { nodes = (nodes n) V.// [(fromIntegral i,(1,i,i,i))] 185 | , freed = i:(freed n) 186 | }) 187 | 188 | getNode :: Word64 -> State Net Node 189 | getNode i = (\vs -> vs V.! (fromIntegral i)) <$> gets nodes 190 | 191 | getPort :: Slot -> Node -> (Slot, Word64) 192 | getPort s (b,m,l,r) = 193 | let i = readInfoBits b in 194 | case s of 195 | M -> (mainSlot i,m) 196 | L -> (leftSlot i,l) 197 | R -> (rightSlot i,r) 198 | 199 | enterPort :: (Slot, Word64) -> State Net (Slot,Word64) 200 | enterPort (s, n) = do 201 | node <- getNode n 202 | return $ (getPort s node) 203 | 204 | setSlot :: Node -> Slot -> (Slot, Word64) -> Node 205 | setSlot node@(b,m,l,r) x (s,n) = 206 | let i = readInfoBits b in 207 | case x of 208 | M -> (infoBits $ i { mainSlot = s }, n, l, r) 209 | L -> (infoBits $ i { leftSlot = s }, m, n, r) 210 | R -> (infoBits $ i { rightSlot = s }, m, l, n) 211 | 212 | setPort :: Slot -> Word64 -> (Slot,Word64) -> State Net () 213 | setPort s i port = do 214 | node <- ((\x -> x V.! (fromIntegral i)) <$> gets nodes) 215 | modify $ \n -> 216 | n { nodes = (nodes n) V.// [(fromIntegral i, (setSlot node s port))] } 217 | 218 | linkSlots :: (Slot,Word64) -> (Slot, Word64) -> State Net () 219 | linkSlots (sa,ia) (sb,ib) = do 220 | setPort sa ia $ (sb,ib) 221 | setPort sb ib $ (sa,ia) 222 | when (sa == M && sb == M) $ 223 | modify (\n -> n { redex = (ia, ib) : redex n }) 224 | 225 | linkPorts :: (Slot,Word64) -> (Slot,Word64) -> State Net () 226 | linkPorts (sa,ia) (sb,ib) = linkSlots (sa,ia) (sb,ib) 227 | 228 | unlinkPort :: (Slot,Word64) -> State Net () 229 | unlinkPort (sa,ia) = do 230 | (sb,ib) <- enterPort (sa,ia) 231 | (sa',ia') <- enterPort (sb,ib) 232 | if (ia' == ia && sa' == sa) then do 233 | setPort sa ia (sa,ia) 234 | setPort sb ib (sb,ib) 235 | else return () 236 | 237 | rewrite :: (Word64, Word64) -> State Net () 238 | rewrite (iA, iB) = do 239 | nodes <- gets $ nodes 240 | let a = nodes V.! (fromIntegral iA) 241 | let b = nodes V.! (fromIntegral iB) 242 | if 243 | | (getNType a == getNType b) -> do 244 | aLdest <- enterPort (L,iA) 245 | bLdest <- enterPort (L,iB) 246 | linkPorts aLdest bLdest 247 | aRdest <- enterPort (R,iA) 248 | bRdest <- enterPort (R,iB) 249 | linkPorts aRdest bRdest 250 | return () 251 | | otherwise -> do 252 | iP <- allocNode (getNType b) 253 | iQ <- allocNode (getNType b) 254 | iR <- allocNode (getNType a) 255 | iS <- allocNode (getNType a) 256 | linkSlots (L,iS) (R,iP) 257 | linkSlots (R,iR) (L,iQ) 258 | linkSlots (R,iS) (R,iQ) 259 | linkSlots (L,iR) (L,iP) 260 | a1dest <- enterPort (L,iA) 261 | a2dest <- enterPort (R,iA) 262 | b1dest <- enterPort (L,iB) 263 | b2dest <- enterPort (R,iB) 264 | linkPorts (M,iP) a1dest 265 | linkPorts (M,iQ) a2dest 266 | linkPorts (M,iR) b1dest 267 | linkPorts (M,iS) b2dest 268 | mapM_ (\x -> unlinkPort (x,iA)) [M,L,R] >> freeNode iA 269 | unless (iA == iB) (mapM_ (\x -> unlinkPort (x,iB)) [M,L,R] >> freeNode iB) 270 | return () 271 | 272 | reduce :: Net -> (Net, Int) 273 | reduce x = go (x {redex = (findRedexes (nodes x))}) 0 274 | where 275 | go n c = case redex n of 276 | [] -> (n, c) 277 | r:rs -> go (execState (rewrite r) (n { redex = rs })) (c + 1) 278 | 279 | inCD :: Net 280 | inCD= makeNet 281 | [ mkNode Con M 1 L 2 L 3 282 | , mkNode Dup M 0 L 4 L 5 283 | , mkSet L 0 284 | , mkSet R 0 285 | , mkSet L 1 286 | , mkSet R 1 287 | ] 288 | 289 | inCC :: Net 290 | inCC = makeNet 291 | [ mkNode Con M 1 L 2 L 3 292 | , mkNode Con M 0 L 4 L 5 293 | , mkSet L 0 294 | , mkSet R 0 295 | , mkSet L 1 296 | , mkSet R 1 297 | ] 298 | 299 | inCE :: Net 300 | inCE = makeNet 301 | [ mkNode Con M 0 L 1 L 2 302 | , mkSet L 0 303 | , mkSet R 0 304 | ] 305 | -------------------------------------------------------------------------------- /src/SimplerCore.hs: -------------------------------------------------------------------------------- 1 | module SimplerCore where 2 | 3 | type Name = String 4 | 5 | data Term 6 | = Var Int 7 | | Typ 8 | | Val Int 9 | | Num 10 | | Lam Name Term Term 11 | | App Term Term 12 | | All Name Term Term 13 | | Mu Name Term 14 | | Any -- Type of any term 15 | | Rec Int 16 | | Slf Name Term 17 | deriving (Eq, Show, Ord) 18 | 19 | hasFreeVar :: Term -> Int -> Bool 20 | hasFreeVar term n = case term of 21 | Var i -> i == n 22 | All _ h b -> hasFreeVar h n || hasFreeVar b (n + 1) 23 | Lam _ h b -> hasFreeVar h n || hasFreeVar b (n + 1) 24 | App f a -> hasFreeVar f n || hasFreeVar a n 25 | Slf _ t -> hasFreeVar t (n + 1) 26 | Mu _ t -> hasFreeVar t n 27 | _ -> False 28 | 29 | pretty t = putStrLn $ go t [] [] 30 | where 31 | go :: Term -> [String] -> [String] -> String 32 | go t vs rs = case t of 33 | Var i -> if i < length vs then vs !! i else concat ["^", show i] 34 | Rec i -> if i < length rs then rs !! i else concat ["#", show i] 35 | Typ -> "Type" 36 | All n h@Typ b -> concat ["∀(", n, "). ", go b (n : vs) rs] 37 | All n h@(All _ _ _) b -> if hasFreeVar b 0 then concat ["(", n, " : ", go h vs rs, ") -> ", go b (n : vs) rs] else concat ["(", go h vs rs, ") -> ", go b (n : vs) rs] 38 | All n h b -> if hasFreeVar b 0 then concat ["(", n, " : ", go h vs rs, ") -> ", go b (n : vs) rs] else concat [go h vs rs, " -> ", go b (n : vs) rs] 39 | Lam n h@Any b@(Lam _ _ _) -> concat ["(", n, ", ", tail $ go b (n : vs) rs] 40 | Lam n h@Any b -> concat ["(", n, ") => ", go b (n : vs) rs] 41 | Lam n h b@(Lam _ _ _) -> concat ["(", n, " : ", go h vs rs, ", ", tail $ go b (n : vs) rs] 42 | Lam n h b -> concat ["(", n, " : ", go h vs rs, ") => ", go b (n : vs) rs] 43 | App f@(App _ _) a -> 44 | concat [init $ go f vs rs, " ", go a vs rs, ")"] 45 | App f@(Lam _ _ _) a -> 46 | concat ["((", go f vs rs, ") " , go a vs rs, ")"] 47 | App f@(Mu _ _) a -> 48 | concat ["((", go f vs rs, ") " , go a vs rs, ")"] 49 | App f a -> concat ["(", go f vs rs, " ", go a vs rs, ")"] 50 | Slf n t -> concat ["${", n, "} (", go t (n : vs) rs, ")"] 51 | Mu n t -> concat ["μ(", n, "). ", go t vs (n : rs)] 52 | Num -> "Number" 53 | Val i -> show i 54 | Any -> "Any" 55 | 56 | shiftVar :: Term -> Int -> Int -> Term 57 | shiftVar term inc dep = case term of 58 | Var i -> Var (if i < dep then i else (i + inc)) 59 | All n h b -> All n (shiftVar h inc dep) (shiftVar b inc (dep + 1)) 60 | Lam n h b -> Lam n (shiftVar h inc dep) (shiftVar b inc (dep + 1)) 61 | App f a -> App (shiftVar f inc dep) (shiftVar a inc dep) 62 | Slf n t -> Slf n (shiftVar t inc (dep + 1)) 63 | Mu n t -> Mu n (shiftVar t inc dep) 64 | x -> x 65 | 66 | shiftRec :: Term -> Int -> Int -> Term 67 | shiftRec term inc dep = case term of 68 | Lam n h b -> Lam n (shiftRec h inc dep) (shiftRec b inc dep) 69 | All n h b -> All n (shiftRec h inc dep) (shiftRec b inc dep) 70 | App f a -> App (shiftRec f inc dep) (shiftRec a inc dep) 71 | Mu n t -> Mu n (shiftRec t inc (dep + 1)) 72 | Slf n t -> Slf n (shiftRec t inc dep) 73 | Rec i -> Rec (if i < dep then i else (i + inc)) 74 | x -> x 75 | 76 | substVar :: Term -> Term -> Int -> Term 77 | substVar term v dep = case term of 78 | Var i -> if i == dep then v else Var (i - if i > dep then 1 else 0) 79 | All n h b -> All n (substVar h v dep) (substVar b vV (dep + 1)) 80 | Lam n h b -> Lam n (substVar h v dep) (substVar b vV (dep + 1)) 81 | App f a -> App (substVar f v dep) (substVar a v dep) 82 | Mu n t -> Mu n (substVar t vR dep) 83 | Slf n t -> Slf n (substVar t vV (dep + 1)) 84 | x -> x 85 | where 86 | vV = shiftVar v 1 0 87 | vR = shiftRec v 1 0 88 | 89 | substRec :: Term -> Term -> Int -> Term 90 | substRec term v dep = case term of 91 | All n h b -> All n (substRec h v dep) (substRec b vV dep) 92 | Lam n h b -> Lam n (substRec h v dep) (substRec b vV dep) 93 | App f a -> App (substRec f v dep) (substRec a v dep) 94 | Mu n t -> Mu n (substRec t vR (dep + 1)) 95 | Slf n t -> Slf n (substRec t vV dep) 96 | Rec i -> if i == dep then v else Rec (i - if i > dep then 1 else 0) 97 | x -> x 98 | where 99 | vV = shiftVar v 1 0 100 | vR = shiftRec v 1 0 101 | 102 | maxFreeVar :: Term -> Int 103 | maxFreeVar term = go term 0 where 104 | go term n = case term of 105 | Var i -> if i < n then 0 else i-n 106 | All _ h b -> go h n `max` go b (n + 1) 107 | Lam _ h b -> go h n `max` go b (n + 1) 108 | App f a -> go f n `max` go a n 109 | Slf _ t -> go t (n + 1) 110 | Mu _ t -> go t n 111 | _ -> 0 112 | 113 | substManyVar :: Term -> [Term] -> Int -> Term 114 | substManyVar t vals d = go t vals d 0 115 | where 116 | l = length vals - 1 117 | go t (v:vs) d i = 118 | go (substVar t (shiftVar v (l - i) 0) (d + l - i)) vs d (i + 1) 119 | go t [] d i = t 120 | 121 | eval :: Term -> Term 122 | eval term = case term of 123 | All n h b -> All n (eval h) (eval b) 124 | Lam n h b -> Lam n (eval h) (eval b) 125 | App f a -> 126 | let a' = eval a 127 | in case eval f of 128 | Lam _ _ b -> eval (substVar b a' 0) 129 | f -> App f a' 130 | Mu n t -> Mu n (eval t) 131 | Slf n t -> Slf n (eval t) 132 | _ -> term 133 | 134 | unroll :: Term -> Term 135 | unroll term = case term of 136 | All n h b -> All n (unroll h) (unroll b) 137 | Lam n h b -> Lam n (unroll h) (unroll b) 138 | App f a -> App (unroll f) (unroll a) 139 | Mu n t -> substRec t (Mu n t) 0 140 | Slf n t -> Slf n (unroll t) 141 | _ -> term 142 | 143 | contractibleSubst :: Term -> Int -> Bool 144 | contractibleSubst t n = case t of 145 | Var i -> i /= n 146 | Mu _ t -> contractibleSubst t (n + 1) 147 | Lam _ _ _ -> False 148 | App _ _ -> False 149 | _ -> True 150 | 151 | -- The Lam and App cases could potentially be, instead 152 | -- Lam _ t b -> contractibleSubst t n || contractibleSubst b (n + 1) 153 | -- App f a -> contractibleSubst f n || contractibleSubst a n 154 | -- However, a contractible term T would lose the useful property that if it is normalized, then T^n is also normalized, 155 | -- for any power n, where T^n means substitute variable 0 in T by itself n times, that is, 156 | -- `T^0 = Var 0` and `T^(n+1) = subst T^n T 0`. This means in particular that if T is contractible, 157 | -- then `Mu "X" T` is normalized no matter how many times we unroll it. 158 | 159 | 160 | -- Examples of substitutions which are not contractible when you consider evaluation of terms, which rule out `Lam` and `App` as guards for recursion 161 | notcontractible1 = Mu "X" (Lam "a" Typ (App (Rec 0) (Var 0))) 162 | notcontractible2 = Mu "X" (App (Lam "a" Typ (Var 0)) (Rec 0)) 163 | 164 | isBohmRec :: Term -> Int -> Bool 165 | isBohmRec t n = case t of 166 | Var i -> i /= n 167 | Mu _ t -> isBohmRec t (n + 1) 168 | _ -> True 169 | 170 | isBohm :: Term -> Bool 171 | isBohm t = case t of 172 | App f a -> isBohm f && isBohm a 173 | Lam _ h b -> isBohm h && isBohm b 174 | All _ h b -> isBohm h && isBohm b 175 | Mu _ t -> isBohmRec t 0 && isBohm t 176 | Slf _ t -> isBohm t 177 | _ -> True 178 | 179 | evalBohm :: Term -> Term 180 | evalBohm term = case term of 181 | All n h b -> All n (evalBohm h) (evalBohm b) 182 | Lam n h b -> Lam n (evalBohm h) (evalBohm b) 183 | App f a -> case (evalBohm f, evalBohm a) of 184 | (Mu n t@(Lam _ _ _), Var i) -> App (Mu n t) (Var i) 185 | (Mu n t@(Lam _ _ _), Rec i) -> App (Mu n t) (Rec i) 186 | (Mu n t@(Lam _ _ _), a') -> evalBohm $ App (substRec t (Mu n t) 0) a' 187 | (Lam _ _ b, a') -> evalBohm (substVar b a' 0) 188 | (f', a') -> App f' a' 189 | Mu n t -> Mu n (evalBohm t) 190 | Slf n t -> Slf n (evalBohm t) 191 | _ -> term 192 | 193 | -- Examples of evaluation 194 | zero = Lam "Z" Any (Lam "S" Any (Var 1)) 195 | suc = Lam "n" Any (Lam "Z" Any (Lam "S" Any (App (Var 0) (Var 2)))) 196 | double = Mu "double" $ Lam "n" Any $ App (App (Var 0) zero) $ Lam "x" Any $ App suc $ App suc $ App (Rec 0) (Var 0) 197 | double' = Lam "n" Any $ App (App (Var 0) zero) $ Mu "Rec" $ Lam "x" Any $ App suc $ App suc $ App (App (Var 0) zero) (Rec 0) 198 | 199 | two = evalBohm $ App double $ App suc zero 200 | four = evalBohm $ App double two 201 | -------------------------------------------------------------------------------- /src/test.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | type Name = String 4 | 5 | data Term = Var Int | Ref Name Int deriving (Eq, Show) 6 | 7 | data Binder = VarB Name | RefB Name deriving (Eq, Show) 8 | 9 | deBind :: [Binder] -> Int -> Name -> Term 10 | deBind bs carets nam = go bs carets 0 0 11 | where 12 | go (x:xs) caretsLeft varIndex refCount 13 | | VarB n <- x, n == nam, caretsLeft == 0 = Var varIndex 14 | | VarB n <- x, n == nam = go xs (caretsLeft - 1) (varIndex + 1) refCount 15 | | VarB n <- x, n /= nam = go xs caretsLeft (varIndex + 1) refCount 16 | | RefB n <- x, n == nam, caretsLeft == 0 = Ref nam refCount 17 | | RefB n <- x, n == nam = go xs (caretsLeft - 1) varIndex (refCount + 1) 18 | | otherwise = go xs caretsLeft varIndex refCount 19 | go [] caretsLeft varIndex refCount = Ref nam (caretsLeft + refCount) 20 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.21 2 | 3 | extra-deps: 4 | - equivalence-0.3.5@sha256:aedbd070b7ab5e58dd1678cd85607bc33cb9ff62331c1fa098ca45063b3072db 5 | - STMonadTrans-0.4.4@sha256:437eec4fdf5f56e9cd4360e08ed7f8f9f5f02ff3f1d634a14dbc71e890035387 6 | 7 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | import Spec.Net as Net 7 | import Spec.Parser as Parser 8 | import Spec.Core as Core 9 | 10 | 11 | main :: IO () 12 | main = hspec $ do 13 | -- describe "Net" $ Net.spec 14 | describe "Parser" $ Parser.spec 15 | describe "Core" $ Core.spec 16 | -------------------------------------------------------------------------------- /test/Spec/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Spec.Core where 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import Control.Monad.Identity 9 | import Control.Monad.State.Strict 10 | 11 | import Data.Void 12 | import Data.Maybe 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import qualified Data.Map.Strict as M 16 | import Data.Set (Set) 17 | import qualified Data.Set as Set 18 | 19 | import Text.Megaparsec hiding (State) 20 | import Text.RawString.QQ 21 | 22 | import qualified Data.Text as T 23 | import qualified Data.Text.IO as TIO 24 | 25 | import Core 26 | import Lang hiding (Term(..)) 27 | import CoreSyn hiding (_terms) 28 | import Parser hiding (Term(..)) 29 | 30 | data Err 31 | = ErrParse (ParseErrorBundle Text Void) 32 | | ErrSyn SynError 33 | | ErrEval 34 | deriving (Eq,Show) 35 | 36 | parse' :: Show a => Parser a -> Text -> Either Err (a, ParseState) 37 | parse' p s = let 38 | l = Left . ErrParse 39 | r = \(a, st, w) -> Right (a,st) 40 | in either l r (parseDefault p s) 41 | 42 | -- core synthesis test 43 | syn' :: Text -> Either Err Core.Module 44 | syn' txt = do 45 | (ds, ParseState _ ns _) <- parse' premodule txt 46 | let env = SynEnv $ M.fromList $ (\x -> (x,[x])) <$> (Set.toList ns) 47 | let ste = SynState 0 M.empty 48 | either (Left . ErrSyn) Right $ coreSyn env ste ds 49 | 50 | eval' :: Name -> Text -> Either Err Term 51 | eval' name txt = do 52 | modl <- syn' txt 53 | term <- maybe (Left ErrEval) Right $ M.lookup name (_defs modl) 54 | return $ eval term modl 55 | 56 | 57 | synFile:: FilePath -> IO () 58 | synFile f = do 59 | txt <- TIO.readFile f 60 | print $ syn' txt 61 | 62 | evalFile:: FilePath -> IO () 63 | evalFile f = do 64 | txt <- TIO.readFile f 65 | prettyModule $ syn' txt 66 | print $ eval' "main" txt 67 | 68 | debug_evalFile:: FilePath -> IO Term 69 | debug_evalFile f = do 70 | txt <- TIO.readFile f 71 | let s = syn' txt 72 | prettyModule $ s 73 | a <- either (\x -> print x >> error "Error") return s 74 | term <- maybe (error "Error") return $ M.lookup "main" (_defs a) 75 | debug_eval term a 76 | 77 | 78 | prettyModule :: Either Err Core.Module -> IO () 79 | prettyModule (Left e) = print e 80 | prettyModule (Right (Module m)) = go (M.toList m) 81 | where 82 | go ((n,t):ns) = putStr (T.unpack n) >> putStr " = " >> print t >> go ns 83 | go [] = putStrLn "" 84 | 85 | spec :: SpecWith () 86 | spec = do 87 | describe "Application" $ do 88 | it "applying a lambda: \"((x) => x)(1) ~> 1\"" $ do 89 | eval' "f" "f ((x) => x)(1)" `shouldBe` (Right $ U64 1) 90 | 91 | describe "References" $ do 92 | it "referencing a Let: \"let x = 0; x\"" $ do 93 | eval' "f" "f let x = 0; x" `shouldBe` (Right $ U64 0) 94 | it "name-shadowing with let: \"let x = 1; let x = 0; x\"" $ do 95 | eval' "f" "f let x = 1; let x = 0; x" `shouldBe` (Right $ U64 0) 96 | it "\"umbral\" referencing of shadowed names: \"let x = 1; let x = 0; ^x\"" $ do 97 | eval' "f" "f let x = 1; let x = 0; ^x" `shouldBe` (Right $ U64 1) 98 | it "CoreSyn Error: can't reference out of scope: \"let x = 1; let x = 0; ^^x\"" $ do 99 | eval' "f" "f let x = 1; let x = 0; ^^x" 100 | `shouldBe` 101 | (Left $ ErrSyn 102 | (UndefinedReference "x" 2 0 103 | (M.fromList [("f",["f"]), ("x", ["$x1","$x0"])]) 104 | ) 105 | ) 106 | 107 | describe "mixing lets and lambdas" $ do 108 | it "\"let x = 2; let x = 1; ((x) => x)(0)\"" $ do 109 | eval' "f" "f let x = 2; let x = 1; ((x) => x)(0)" 110 | `shouldBe` (Right $ U64 0) 111 | it "\"let x = 2; let x = 1; ((x) => ^x)(0)\"" $ do 112 | eval' "f" "f let x = 2; let x = 1; ((x) => ^x)(0)" 113 | `shouldBe` (Right $ U64 1) 114 | it "\"let x = 2; let x = 1; ((x) => ^^x)(0)\"" $ do 115 | eval' "f" "f let x = 2; let x = 1; ((x) => ^^x)(0)" 116 | `shouldBe` (Right $ U64 2) 117 | 118 | it "\"let x = 2; let x = 1; ((x) => ^^^x)(0)\"" $ do 119 | eval' "f" "f let x = 2; let x = 1; ((x) => ^^^x)(0)" 120 | `shouldBe` 121 | (Left $ ErrSyn (UndefinedReference "x" 2 1 122 | (M.fromList [("f",["f"]), ("x",["$x1", "$x0"])])) 123 | ) 124 | it "\"(x) => let x = 1; let x = 0; x)(2)\"" $ do 125 | eval' "f" "f ((x) => let x = 1; let x = 0; x)(2)" 126 | `shouldBe` (Right $ U64 0) 127 | it "\"((x) => let x = 1; let x = 0; ^x)(2)\"" $ do 128 | eval' "f" "f ((x) => let x = 1; let x = 0; ^x)(2)" 129 | `shouldBe` (Right $ U64 1) 130 | it "\"((x) => let x = 1; let x = 0; ^^x)(2)\"" $ do 131 | eval' "f" "f ((x) => let x = 1; let x = 0; ^^x)(2)" 132 | `shouldBe` (Right $ U64 2) 133 | 134 | it "\"((x) => let x = 1; let x = 0; ^^^x)(2)\"" $ do 135 | eval' "f" "f ((x) => let x = 1; let x = 0; ^^^x)(2)" 136 | `shouldBe` 137 | (Left $ ErrSyn (UndefinedReference "x" 2 1 138 | (M.fromList [("f",["f"]), ("x",["$x1", "$x0"])])) 139 | ) 140 | 141 | describe "let block" $ do 142 | it "\"let (x = 1; y = 2); x\"" $ do 143 | eval' "f" "f let (x = 1; y = 2); x" `shouldBe` 144 | (Right $ U64 1) 145 | it "\"let (x = 1; y = 2); let (x = 3; y = 4); ^x\"" $ do 146 | eval' "f" "f let (x = 1; y = 2); let (x = 3; y = 4); ^x" `shouldBe` 147 | (Right $ U64 1) 148 | it "\"let (f(x,y) = x; y = f(1,2)); y\"" $ do 149 | eval' "f" "f let (f(x,y) = x; y = f(1,2)); y" `shouldBe` 150 | (Right $ U64 1) 151 | 152 | it "mutual recursion" $ do 153 | (eval' "f" [r| 154 | f 155 | let ( 156 | isOdd(x) = if x === 1 then 1 else isEven(x - 1); 157 | isEven(x) = if x === 1 then 0 else isOdd(x - 1); 158 | ); 159 | isEven(42) 160 | 161 | |]) `shouldBe` (Right $ U64 1) 162 | 163 | (eval' "f" [r| 164 | f 165 | let ( 166 | isOdd(x) = if x === 1 then 1 else isEven(x - 1); 167 | isEven(x) = if x === 1 then 0 else isOdd(x - 1); 168 | ); 169 | isOdd(43) 170 | 171 | |]) `shouldBe` (Right $ U64 1) 172 | 173 | it "closure" $ do 174 | (eval' "main" [r| 175 | main f(1,2,3) 176 | 177 | f(x,y,z) 178 | let p = x 179 | let q = y 180 | let r = z 181 | p + q + r 182 | |]) `shouldBe` (Right $ U64 6) 183 | 184 | 185 | (eval' "main" [r| 186 | main f(1,2,3,4) 187 | 188 | f(x,y,z) 189 | let q = (a) => x + y + a 190 | (w) => q(1) + g(x,y,z) + w 191 | 192 | g(x,y,z) 193 | let p = x 194 | let q = y 195 | let r = z 196 | p + q + r 197 | |]) `shouldBe` (Right $ U64 14) 198 | 199 | (eval' "main" [r| 200 | main f(1,2,3) 201 | 202 | f(x,y,z) 203 | let q = y + z 204 | if x then q else y 205 | |]) `shouldBe` (Right $ U64 5) 206 | 207 | 208 | -------------------------------------------------------------------------------- /test/Spec/Lang.hs: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /test/Spec/Net.hs: -------------------------------------------------------------------------------- 1 | module Spec.Net where 2 | 3 | import qualified Data.Vector.Unboxed as V 4 | import Data.Word 5 | 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | 9 | import Runtime.Net 10 | 11 | instance Arbitrary NType where 12 | arbitrary = arbitraryBoundedEnum 13 | 14 | instance Arbitrary Slot where 15 | arbitrary = arbitraryBoundedEnum 16 | 17 | instance Arbitrary Info where 18 | arbitrary = Info 19 | <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 20 | <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary 21 | 22 | prop_readInfo :: Info -> Bool 23 | prop_readInfo l = l == (readInfoBits . infoBits) l 24 | 25 | outCD :: Net 26 | outCD = 27 | Net (V.fromList [(1,0,0,0),(1,1,1,1),(71,0,8,0),(71,0,9,0),(71,0,6,0),(71,0,7,0),(84,4,8,9),(164,5,8,9),(86,2,6,7),(166,3,6,7)]) 28 | [0,1] 29 | [] 30 | 31 | outCC :: Net 32 | outCC = 33 | Net (V.fromList [(1,0,0,0),(1,1,1,1),(87,0,4,0),(87,0,5,0),(87,0,2,0),(87,0,3,0)]) 34 | [0,1] 35 | [] 36 | 37 | outCE :: Net 38 | outCE = 39 | Net (V.fromList [(1,0,0,0),(87,0,1,0),(87,0,2,0)]) 40 | [0] 41 | [] 42 | 43 | spec :: SpecWith () 44 | spec = do 45 | describe "Net.Node" $ do 46 | it "Info -> Bits -> Info is identity" $ do 47 | property $ prop_readInfo 48 | describe "Annihilation" $ do 49 | it "annihilates CON-CON" $ do 50 | reduce inCC `shouldBe` (outCC, 1) 51 | describe "Self-annihilation" $ do 52 | it "erases CON-ERA" $ do 53 | reduce inCE `shouldBe` (outCE, 1) 54 | describe "Duplication" $ do 55 | it "duplicates CON-DUP" $ do 56 | reduce inCD `shouldBe` (outCD, 1) 57 | -------------------------------------------------------------------------------- /test/Spec/Parser.hs: -------------------------------------------------------------------------------- 1 | module Spec.Parser where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | import Spec.Parser.Lang as Lang 7 | import Spec.Parser.PreModule as PreModule 8 | 9 | spec :: SpecWith () 10 | spec = do 11 | describe "Lang" $ Lang.spec 12 | describe "PreModule" $ PreModule.spec 13 | -------------------------------------------------------------------------------- /test/Spec/Parser/Lang.hs: -------------------------------------------------------------------------------- 1 | module Spec.Parser.Lang where 2 | 3 | import Prelude hiding (log) 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import Control.Monad.Identity 9 | import Control.Monad.State.Strict 10 | 11 | import Data.Map.Strict (Map) 12 | import qualified Data.Map.Strict as M 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import Data.Void 16 | 17 | import Text.Megaparsec hiding (State) 18 | import Text.Megaparsec.Char 19 | import qualified Text.Megaparsec.Char.Lexer as L 20 | 21 | import Control.Monad.RWS.Lazy hiding (All) 22 | 23 | import Core (Eras (..), Name, Op (..)) 24 | import Lang 25 | import Parser.Lang 26 | import Spec.Parser.Utils 27 | 28 | spec :: SpecWith () 29 | spec = do 30 | describe "Names" $ do 31 | it "initial letter or underscores: \"_a\"" $ do 32 | parse' name "a" `shouldBe` (Just "a") 33 | parse' name "_a" `shouldBe` (Just "_a") 34 | it "initial underscores allow for post-initial number: \"_1\"" $ do 35 | parse' name "_1" `shouldBe` (Just "_1") 36 | it "initial number fails : \"1\"" $ do 37 | parse' name "1" `shouldBe` Nothing 38 | it "names with only symbols should fail: \"__\"" $ do 39 | parse' name "_" `shouldBe` Nothing 40 | parse' name "__" `shouldBe` Nothing 41 | parse' name "_." `shouldBe` Nothing 42 | it "symbols following initial letter okay: \"a_\"" $ do 43 | parse' name "a_" `shouldBe` (Just "a_") 44 | parse' name "a_." `shouldBe` (Just "a_.") 45 | it "reserved words fail: \"let\", \"T\"" $ do 46 | parse' name "let" `shouldBe` Nothing 47 | parse' name "T" `shouldBe` Nothing 48 | 49 | describe "Forall/Lambdas" $ do 50 | it "basic syntax: \"(A : Type) => A\"" $ do 51 | parse' allLam "(A : Type) => A" `shouldBe` 52 | (Just $ Lam "A" Typ Keep (Var 0)) 53 | parse' allLam "(A : Type) -> A" `shouldBe` 54 | (Just $ All "A" Typ Keep (Var 0)) 55 | 56 | it "erased arguments: \"(A : Type;) => A\"" $ do 57 | parse' allLam "(A : Type;) => A" `shouldBe` 58 | (Just $ Lam "A" Typ Eras (Var 0)) 59 | parse' allLam "(A : Type;) -> A" `shouldBe` 60 | (Just $ All "A" Typ Eras (Var 0)) 61 | 62 | it "multiple arguments: \"(A : Type, B : Type) => A\"" $ do 63 | parse' allLam "(A : Type, B : Type) => A" `shouldBe` 64 | (Just $ (Lam "A" Typ Keep (Lam "B" Typ Keep (Var 1)))) 65 | parse' allLam "(A : Type, B : Type, C : Type) => A" `shouldBe` 66 | (Just $ 67 | (Lam "A" Typ Keep (Lam "B" Typ Keep (Lam "C" Typ Keep (Var 2))))) 68 | 69 | it "holes for argument type: \"(A) => A\"" $ do 70 | parse' allLam "(A) => A" `shouldBe` 71 | (Just $ Lam "A" (Hol "#0") Keep (Var 0)) 72 | parse' allLam "(A,B) => A" `shouldBe` 73 | (Just $ (Lam "A" (Hol "#0") Keep (Lam "B" (Hol "#1") Keep (Var 1)))) 74 | 75 | it "anonymous arguments: \"(:Type) -> A\"" $ do 76 | parse' allLam "(:Type) -> A" `shouldBe` 77 | (Just $ All "_" Typ Keep (Ref "A" 0 1)) 78 | parse' allLam "(:Type, :Type) -> A" `shouldBe` 79 | (Just $ All "_" Typ Keep (All "_" Typ Keep (Ref "A" 0 2))) 80 | 81 | 82 | it "correct deBruijn indices" $ do 83 | parse' allLam "(A : Type, x : A) -> A" `shouldBe` 84 | (Just $ (All "A" Typ Keep (All "x" (Var 0) Keep (Var 1)))) 85 | parse' allLam "(A : Type, B : Type, x : A) -> A" `shouldBe` 86 | (Just $ 87 | (All "A" Typ Keep (All "B" Typ Keep (All "x" (Var 1) Keep (Var 2))))) 88 | parse' allLam "(x : Word, Q : (y : Word) -> Type) -> Q(x)" `shouldBe` 89 | (Just $ 90 | All "x" Wrd Keep 91 | (All "Q" (All "y" Wrd Keep Typ) Keep 92 | (App (Var 0) (Var 1) Keep))) 93 | parse' allLam "(x : Word, Q : Word -> Type) -> Q(x)" `shouldBe` 94 | (Just $ 95 | All "x" Wrd Keep 96 | (All "Q" (All "_" Wrd Keep Typ) Keep 97 | (App (Var 0) (Var 1) Keep))) 98 | describe "Application" $ do 99 | it "function style applications: \"f(a)\"" $ do 100 | parse' term "f(a)" `shouldBe` (Just (App (Ref "f" 0 0) (Ref "a" 0 0) Keep)) 101 | it "multiple arguments: \"f(a,b,c)\"" $ do 102 | parse' term "f(a,b)" `shouldBe` 103 | (Just (App (App (Ref "f" 0 0) (Ref "a" 0 0) Keep) (Ref "b" 0 0) Keep)) 104 | parse' term "f(a,b,c)" `shouldBe` 105 | (Just 106 | (App (App (App 107 | (Ref "f" 0 0) 108 | (Ref "a" 0 0) Keep) 109 | (Ref "b" 0 0) Keep) 110 | (Ref "c" 0 0) Keep)) 111 | it "parenthesized arguments: \"f(a)(b)(c)\"" $ do 112 | parse' term "f(a)(b)(c)" `shouldBe` 113 | (Just 114 | (App (App (App 115 | (Ref "f" 0 0) 116 | (Ref "a" 0 0) Keep) 117 | (Ref "b" 0 0) Keep) 118 | (Ref "c" 0 0) Keep)) 119 | it "erased parenthesized arguments: \"f(a;)(b;)(c;)\"" $ do 120 | parse' term "f(a;)(b;)(c;)" `shouldBe` 121 | (Just 122 | (App (App (App 123 | (Ref "f" 0 0) 124 | (Ref "a" 0 0) Eras) 125 | (Ref "b" 0 0) Eras) 126 | (Ref "c" 0 0) Eras)) 127 | it "erased arguments: \"f(a;b;c;)\"" $ do 128 | parse' term "f(a;b;c;)" `shouldBe` 129 | (Just 130 | (App (App (App 131 | (Ref "f" 0 0) 132 | (Ref "a" 0 0) Eras) 133 | (Ref "b" 0 0) Eras) 134 | (Ref "c" 0 0) Eras)) 135 | it "applying a lambda: \"((x) => x)(a,b)\"" $ do 136 | parse' term "((x) => x)(a,b)" `shouldBe` 137 | (Just (App (App 138 | (Lam "x" (Hol "#0") Keep (Var 0)) 139 | (Ref "a" 0 0) Keep) 140 | (Ref "b" 0 0) Keep)) 141 | it "lambda style applications: \"(f a b c)\"" $ do 142 | parse' term "(f a b c)" `shouldBe` 143 | (Just (App (App (App 144 | (Ref "f" 0 0) 145 | (Ref "a" 0 0) Keep) 146 | (Ref "b" 0 0) Keep) 147 | (Ref "c" 0 0) Keep)) 148 | it "lambda style applications: \"(f (a b) c)\"" $ do 149 | parse' term "(f (a b) c)" `shouldBe` 150 | (Just (App (App 151 | (Ref "f" 0 0) 152 | (App (Ref "a" 0 0) (Ref "b" 0 0) Keep) Keep) 153 | (Ref "c" 0 0) Keep)) 154 | parse' term "(f (a (b c)))" `shouldBe` 155 | (Just 156 | (App (Ref "f" 0 0) 157 | (App (Ref "a" 0 0) 158 | (App (Ref "b" 0 0) (Ref "c" 0 0) Keep) 159 | Keep) 160 | Keep)) 161 | 162 | describe "Let" $ do 163 | it "simple let" $ do 164 | parse' let_ "let x = 1; 2" `shouldBe` 165 | (Just $ Let (M.fromList [("x", U64 1)]) (U64 2)) 166 | it "bare reference: \"x\"" $ do 167 | parse' term "x" `shouldBe` (Just (Ref "x" 0 0)) 168 | it "referencing a Let: \"let x = 0; x\"" $ do 169 | parse' let_ "let x = 0; x" `shouldBe` 170 | (Just $ Let (M.fromList [("x",U64 0)]) (Ref "x" 0 0)) 171 | it "name-shadowing with let: \"let x = 1; let x = 0; x\"" $ do 172 | parse' let_ "let x = 1; let x = 0; x" `shouldBe` 173 | (Just $ 174 | Let (M.fromList [("x",U64 1)]) $ 175 | Let (M.fromList [("x",U64 0)]) $ 176 | (Ref "x" 0 0)) 177 | it "unshadowing: \"let x = 1; let x = 0; ^x\"" $ do 178 | parse' let_ "let x = 1; let x = 0; ^x" `shouldBe` 179 | (Just $ 180 | Let (M.fromList [("x",U64 1)]) $ 181 | (Let (M.fromList [("x",U64 0)]) $ 182 | (Ref "x" 1 0))) 183 | it "referencing out of local scope: \"let x = 1; let x = 0; ^^x\"" $ do 184 | parse' let_ "let x = 1; let x = 0; ^^x" `shouldBe` 185 | (Just $ 186 | Let (M.fromList [("x",U64 1)]) $ 187 | Let (M.fromList [("x",U64 0)]) $ 188 | (Ref "x" 2 0)) 189 | it "mixing lets and lambdas: \"let x = 2; let x = 1; ((x) => x)(0)\"" $ do 190 | parse' let_ "let x = 2; let x = 1; ((x) => x)(0)" `shouldBe` 191 | (Just $ 192 | Let (M.fromList [("x",U64 2)]) $ 193 | Let (M.fromList [("x",U64 1)]) $ 194 | (App (Lam "x" (Hol "#0") Keep (Var 0)) (U64 0) Keep)) 195 | parse' let_ "let x = 2; let x = 1; ((x) => ^x)(0)" `shouldBe` 196 | (Just $ 197 | Let (M.fromList [("x",U64 2)]) $ 198 | Let (M.fromList [("x",U64 1)]) $ 199 | (App (Lam "x" (Hol "#0") Keep (Ref "x" 0 1)) (U64 0) Keep)) 200 | parse' term "let x = 2; let x = 1; ((x) => ^^x)(0)" `shouldBe` 201 | (Just $ 202 | Let (M.fromList [("x",U64 2)]) $ 203 | Let (M.fromList [("x",U64 1)]) $ 204 | (App (Lam "x" (Hol "#0") Keep (Ref "x" 1 1)) (U64 0) Keep)) 205 | parse' term "let x = 2; let x = 1; ((x) => ^^^x)(0)" `shouldBe` 206 | (Just $ 207 | Let (M.fromList [("x",U64 2)]) $ 208 | Let (M.fromList [("x",U64 1)]) $ 209 | (App (Lam "x" (Hol "#0") Keep (Ref "x" 2 1)) (U64 0) Keep)) 210 | parse' term "((x) => let x = 1; let x = 0; x)(2)" `shouldBe` 211 | (Just $ 212 | App 213 | (Lam "x" (Hol "#0") Keep $ 214 | Let (M.fromList [("x",U64 1)]) $ 215 | Let (M.fromList [("x",U64 0)]) $ 216 | (Ref "x" 0 0)) 217 | (U64 2) Keep) 218 | parse' term "((x) => let x = 1; let x = 0; ^x)(2)" `shouldBe` 219 | (Just $ 220 | App 221 | (Lam "x" (Hol "#0") Keep $ 222 | Let (M.fromList [("x",U64 1)]) $ 223 | Let (M.fromList [("x",U64 0)]) $ 224 | (Ref "x" 1 0)) 225 | (U64 2) Keep) 226 | parse' term "((x) => let x = 1; let x = 0; ^^x)(2)" `shouldBe` 227 | (Just $ 228 | App (Lam "x" (Hol "#0") Keep $ 229 | Let (M.fromList [("x",U64 1)]) $ 230 | Let (M.fromList [("x",U64 0)]) $ 231 | (Var 0)) (U64 2) Keep) 232 | parse' term "((x) => let x = 1; let x = 0; ^^^x)(2)" `shouldBe` 233 | (Just $ 234 | App 235 | (Lam "x" (Hol "#0") Keep $ 236 | Let (M.fromList [("x",U64 1)]) $ 237 | Let (M.fromList [("x",U64 0)]) $ 238 | (Ref "x" 2 1)) (U64 2) Keep) 239 | parse' term "((x) => let x = 2; ((x) => let x = 0; x)(1))(3)" `shouldBe` 240 | (Just $ 241 | App 242 | (Lam "x" (Hol "#0") Keep $ 243 | Let (M.fromList [("x",U64 2)]) $ 244 | (App 245 | (Lam "x" (Hol "#1") Keep $ 246 | Let (M.fromList [("x",U64 0)]) 247 | (Ref "x" 0 0)) 248 | (U64 1) Keep)) 249 | (U64 3) Keep) 250 | parse' term "((x) => let x = 2; ((x) => let x = 0; ^x)(1))(3)" `shouldBe` 251 | (Just $ 252 | App 253 | (Lam "x" (Hol "#0") Keep $ 254 | Let (M.fromList [("x",U64 2)]) $ 255 | (App 256 | (Lam "x" (Hol "#1") Keep $ 257 | Let (M.fromList [("x",U64 0)]) 258 | (Var 0)) 259 | (U64 1) 260 | Keep)) 261 | (U64 3) 262 | Keep) 263 | parse' term "((x) => let x = 2; ((x) => let x = 0; ^^x)(1))(3)" `shouldBe` 264 | (Just $ 265 | App 266 | (Lam "x" (Hol "#0") Keep $ 267 | Let (M.fromList [("x",U64 2)]) $ 268 | (App 269 | (Lam "x" (Hol "#1") Keep $ 270 | Let (M.fromList [("x",U64 0)]) 271 | (Ref "x" 1 1)) 272 | (U64 1) Keep)) 273 | (U64 3) Keep) 274 | parse' term "((x) => let x = 2; ((x) => let x = 0; ^^^x)(1))(3)" `shouldBe` 275 | (Just $ 276 | App 277 | (Lam "x" (Hol "#0") Keep $ 278 | Let (M.fromList [("x",U64 2)]) $ 279 | (App 280 | (Lam "x" (Hol "#1") Keep $ 281 | Let (M.fromList [("x",U64 0)]) $ 282 | (Var 1)) 283 | (U64 1) Keep)) 284 | (U64 3) Keep) 285 | 286 | it "let block" $ do 287 | parse' term "let (x = 1; y = 2); y" `shouldBe` 288 | (Just $ (Let (M.fromList [("x",U64 1),("y",U64 2)]) (Ref "y" 0 0))) 289 | parse' term "let (x = 1 y = 2); y" `shouldBe` 290 | (Just $ (Let (M.fromList [("x",U64 1),("y",U64 2)]) (Ref "y" 0 0))) 291 | 292 | 293 | describe "when/switch" $ do 294 | it "when" $ do 295 | parse' whn "when | x => 0 else 1" `shouldBe` 296 | (Just $ Whn [(Ref "x" 0 0, U64 0)] (U64 1)) 297 | parse' whn "when | x => 0 | y => 1 else 2" `shouldBe` 298 | (Just $ Whn [(Ref "x" 0 0, U64 0),(Ref "y" 0 0, U64 1)] (U64 2)) 299 | parse' whn "when | x === a => 0 | y === b => 1 else 2" `shouldBe` 300 | (Just $ 301 | Whn 302 | [ (Opr EQL (Ref "x" 0 0) (Ref "a" 0 0), U64 0) 303 | , (Opr EQL (Ref "y" 0 0) (Ref "b" 0 0), U64 1) 304 | ] (U64 2)) 305 | it "switch" $ do 306 | parse' swt "switch x | a => 0 else 1" `shouldBe` 307 | (Just $ Swt (Ref "x" 0 0) [(Ref "a" 0 0, U64 0)] (U64 1)) 308 | parse' swt "switch x | a => 0 | b => 2 else 1" `shouldBe` 309 | (Just $ 310 | Swt (Ref "x" 0 0) 311 | [ (Ref "a" 0 0, U64 0) 312 | , (Ref "b" 0 0, U64 2) 313 | ] (U64 1)) 314 | describe "ann/rewrite" $ do 315 | it "annotation" $ do 316 | parse' term "x :: t" `shouldBe` (Just $ Ann (Ref "t" 0 0) (Ref "x" 0 0)) 317 | it "rewrite" $ do 318 | parse' term "x :: rewrite (x) => P(x) with e" `shouldBe` 319 | (Just $ 320 | Ann 321 | (Rwt 322 | (Lam "x" (Hol "#0") Keep (App (Ref "P" 0 1) (Var 0) Keep)) 323 | (Ref "e" 0 0)) 324 | (Ref "x" 0 0)) 325 | 326 | describe "character literals" $ do 327 | it "alphabetic" $ do 328 | parse' chr_ "\'a\'" `shouldBe` (Just $ Chr 'a') 329 | parse' chr_ "\'A\'" `shouldBe` (Just $ Chr 'A') 330 | it "numeric" $ do 331 | parse' chr_ "\'1\'" `shouldBe` (Just $ Chr '1') 332 | parse' chr_ "\'2\'" `shouldBe` (Just $ Chr '2') 333 | it "unicode" $ do 334 | parse' chr_ "\'δ\'" `shouldBe` (Just $ Chr 'δ') 335 | parse' chr_ "\'ヵ\'" `shouldBe` (Just $ Chr 'ヵ') 336 | parse' chr_ "\'😀\'" `shouldBe` (Just $ Chr '😀') 337 | it "escape" $ do 338 | parse' chr_ "\'\\n\'" `shouldBe` (Just $ Chr '\n') 339 | parse' chr_ "\'\\r\'" `shouldBe` (Just $ Chr '\r') 340 | parse' chr_ "\'\\NUL\'" `shouldBe` (Just $ Chr '\NUL') 341 | parse' chr_ "\'\\ACK\'" `shouldBe` (Just $ Chr '\ACK') 342 | parse' chr_ "\'\\xFF\'" `shouldBe` (Just $ Chr '\255') 343 | parse' chr_ "\'\\o77\'" `shouldBe` (Just $ Chr '?') 344 | parse' chr_ "\'\\255\'" `shouldBe` (Just $ Chr '\255') 345 | parse' chr_ "\'\\^@\'" `shouldBe` (Just $ Chr '\^@') 346 | parse' chr_ "\'\\^A\'" `shouldBe` (Just $ Chr '\^A') 347 | 348 | describe "string literals" $ do 349 | it "text" $ 350 | parse' str "\"foobar\"" `shouldBe` (Just $ Str "foobar") 351 | it "string escape" $ 352 | parse' str "\"foo\\&bar\"" `shouldBe` (Just $ Str "foobar") 353 | 354 | -- describe "word literals" $ do 355 | -- it "decimal" $ 356 | 357 | -- it "binary" $ 358 | 359 | 360 | -- it "hexadecimal" $ 361 | 362 | describe "misc. integration" $ do 363 | it "opr from function application: \"P(a) -> A\"" $ do 364 | parse' term "P(a) -> A" `shouldBe` 365 | (Just $ 366 | All "_" (App (Ref "P" 0 0) (Ref "a" 0 0) Keep) Keep 367 | (Ref "A" 0 0)) 368 | 369 | it "terms do not consume leading or trailing whitespace" $ do 370 | parse' (name <* eof) "a" `shouldBe` (Just $ "a") 371 | parse' (name <* eof) "a " `shouldBe` Nothing 372 | parse' (name <* eof) " a" `shouldBe` Nothing 373 | parse' (refVar <* eof) "a" `shouldBe` (Just $ Ref "a" 0 0) 374 | parse' (refVar <* eof) "a " `shouldBe` Nothing 375 | parse' (refVar <* eof) " a" `shouldBe` Nothing 376 | parse' (dbl <* eof) "Double" `shouldBe` (Just $ Dbl) 377 | parse' (dbl <* eof) "Double " `shouldBe` Nothing 378 | parse' (dbl <* eof) " Double" `shouldBe` Nothing 379 | parse' (f64 <* eof) "1.0" `shouldBe` (Just $ F64 1.0) 380 | parse' (f64 <* eof) "1.0 " `shouldBe` Nothing 381 | parse' (f64 <* eof) " 1.0" `shouldBe` Nothing 382 | parse' (wrd <* eof) "Word" `shouldBe` (Just $ Wrd) 383 | parse' (wrd <* eof) "Word " `shouldBe` Nothing 384 | parse' (wrd <* eof) " Word" `shouldBe` Nothing 385 | parse' (u64 <* eof) "1" `shouldBe` (Just $ U64 1) 386 | parse' (u64 <* eof) "1 " `shouldBe` Nothing 387 | parse' (u64 <* eof) " 1" `shouldBe` Nothing 388 | parse' (str <* eof) "\"\"" `shouldBe` (Just $ Str "") 389 | parse' (str <* eof) "\"\" " `shouldBe` Nothing 390 | parse' (str <* eof) " \"\"" `shouldBe` Nothing 391 | parse' (chr_ <* eof) "'a'" `shouldBe` (Just $ Chr 'a') 392 | parse' (chr_ <* eof) "'a' " `shouldBe` Nothing 393 | parse' (chr_ <* eof) " 'a'" `shouldBe` Nothing 394 | parse' (lst <* eof) "[]" `shouldBe` (Just $ Lst []) 395 | parse' (lst <* eof) "[] " `shouldBe` Nothing 396 | parse' (lst <* eof) " []" `shouldBe` Nothing 397 | parse' (slf <* eof) "${x} A" `shouldBe` (Just $ Slf "x" (Ref "A" 0 1)) 398 | parse' (slf <* eof) " ${x} A" `shouldBe` Nothing 399 | parse' (slf <* eof) "${x} A " `shouldBe` Nothing 400 | parse' (new <* eof) "new(A) x" `shouldBe` (Just $ New (Ref "A" 0 0) (Ref "x" 0 0)) 401 | parse' (new <* eof) " new(A) x" `shouldBe` Nothing 402 | parse' (new <* eof) "new(A) x " `shouldBe` Nothing 403 | parse' (log <* eof) "log(A) x" `shouldBe` (Just $ Log (Ref "A" 0 0) (Ref "x" 0 0)) 404 | parse' (log <* eof) " log(A) x" `shouldBe` Nothing 405 | parse' (log <* eof) "log(A) x " `shouldBe` Nothing 406 | -- use 407 | -- ite 408 | -- hol 409 | -- refVar 410 | -- cse 411 | -- whn 412 | -- swt 413 | 414 | --it "nested case" $ do 415 | --parse' cse "case x | foo1 => case y | bar1 => 2 | foo2 => 3" 416 | 417 | -- Problems: 418 | -- "-1" syntax 419 | -- do notation 420 | -- with as 421 | -- rewrite . syntax 422 | -- 423 | -- trailing `,` in args and lst 424 | -- () or #[] pair syntax 425 | -------------------------------------------------------------------------------- /test/Spec/Parser/PreModule.hs: -------------------------------------------------------------------------------- 1 | module Spec.Parser.PreModule where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | 6 | import Control.Monad.Identity 7 | import Control.Monad.State.Strict 8 | 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as M 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Void 14 | 15 | import Core (Eras (..), Name, Op (..)) 16 | import Lang 17 | 18 | import Parser.PreModule 19 | 20 | import Spec.Parser.Utils 21 | 22 | spec :: SpecWith () 23 | spec = do 24 | describe "Def" $ do 25 | it "bare-style definitions: \"a 1\"" $ do 26 | parse' definition "a 1" `shouldBe` (Just $ Expr "a" (U64 1)) 27 | it "semicolon-style definitions: \"a; 1\"" $ do 28 | parse' definition "a; 1" `shouldBe` (Just $ Expr "a" (U64 1)) 29 | it "definitions with arguments: \"a(x) 1\"" $ do 30 | parse' definition "a(x) 1" `shouldBe` (Just $ Expr "a" (Lam "x" (Hol "#0") Keep (U64 1))) 31 | it "definitions with arguments: \"a(x) x\"" $ do 32 | parse' definition "a(x) x" `shouldBe` (Just $ Expr "a" (Lam "x" (Hol "#0") Keep (Var 0))) 33 | it "definitions with arguments (semicolon): \"a(x); 1\"" $ do 34 | parse' definition "a(x); 1" `shouldBe` (Just $ Expr "a"(Lam "x" (Hol "#0") Keep (U64 1))) 35 | it "definitions with types: \"a : Word 1\"" $ do 36 | parse' definition "a : Word 1" `shouldBe` (Just $ Expr "a" (Ann Wrd (U64 1))) 37 | it "definitions with types (semicolon): \"a : Word; 1\"" $ do 38 | parse' definition "a : Word; 1" `shouldBe` (Just $ Expr "a" (Ann Wrd (U64 1))) 39 | it "definitions with arguments and types: \"a(A : Type, x : A) : A; x\"" $ do 40 | parse' definition "a(A : Type, x : A) : A; x" `shouldBe` 41 | (Just $ Expr "a" (Ann (All "A" Typ Keep (All "x" (Var 0) Keep (Var 1))) 42 | (Lam "A" Typ Keep (Lam "x" (Var 0) Keep (Var 0))))) 43 | 44 | describe "ADT" $ do 45 | it "T Empty" $ do 46 | parse' datatype "T Empty" `shouldBe` (Just $ ADT "Empty" [] [] M.empty) 47 | 48 | it "T Bool | true | false" $ do 49 | parse' datatype "T Bool | true | false" `shouldBe` 50 | (Just $ ADT "Bool" [] [] 51 | (M.fromList 52 | [ ("true", Ctor [] Nothing) 53 | , ("false", Ctor [] Nothing) 54 | ] 55 | ) 56 | ) 57 | it "T The{A} (x : A) | the(x : A) : The(A,x)" $ do 58 | parse' datatype "T The{A} (x : A) | the(x : A) : The(A,x)" `shouldBe` 59 | (Just $ 60 | ADT "The" [("A", Hol "#0")] [("x", Var 0)] 61 | (M.fromList 62 | [("the" 63 | , Ctor [("x", Var 0)] 64 | (Just (App (App (Ref "The" 0 2) (Var 1) Keep) (Var 0) Keep))) 65 | ]) 66 | ) 67 | it "T Either{A,B} | lft(value : A) | rgt(value : B)" $ do 68 | parse' datatype "T Either{A,B} | lft(value : A) | rgt(value : B)" `shouldBe` 69 | (Just $ 70 | ADT "Either" [("A", Hol "#0"), ("B",Hol "#1")] [] 71 | (M.fromList 72 | [ ("lft", Ctor [("value", Var 1)] Nothing) 73 | , ("rgt", Ctor [("value", Var 0)] Nothing) 74 | ]) 75 | ) 76 | 77 | describe "Enum" $ do 78 | it "enum | FOO | BAR" $ do 79 | parse' enum "enum | FOO | BAR" `shouldBe` (Just $ Enum Nothing ["FOO", "BAR"]) 80 | parse' enum "enum Foobar | FOO | BAR" `shouldBe` 81 | (Just $ Enum (Just "Foobar") ["FOO", "BAR"]) 82 | 83 | describe "import" $ do 84 | it "import Nat" $ do 85 | parse' import_ "import Nat" `shouldBe` (Just $ Impt "Nat" "") 86 | 87 | --describe "case expressions" $ do 88 | --it "Empty" $ do 89 | -- parse' premodule "T Empty foo case x : Word" `shouldBe` 90 | -- (Just $ 91 | -- [ Data (ADT "Empty" [] [] M.empty) 92 | -- , Expr "foo" (Cse (Ref "x" 0 0) [] M.empty (Just Wrd)) 93 | -- ] 94 | -- ) 95 | --it "Bool" $ do 96 | -- parse' premodule 97 | -- "T Bool | true | false foo case true | true => 1 | false => 2" `shouldBe` 98 | -- (Just $ 99 | -- [ Data (ADT "Bool" [] [] 100 | -- (M.fromList 101 | -- [ ("true", Ctor [] Nothing) 102 | -- , ("false", Ctor [] Nothing) 103 | -- ])) 104 | -- , Expr "foo" (Cse (Ref "true" 0 0) [] 105 | -- (M.fromList [("true",U64 1), ("false",U64 2)]) 106 | -- Nothing) 107 | -- ] 108 | -- ) 109 | -- parse' premodule 110 | -- "T Bool | true | false foo case true | false => 2 | true => 1" `shouldBe` 111 | -- (Just $ 112 | -- [ Data (ADT "Bool" [] [] 113 | -- (M.fromList 114 | -- [ ("true", Ctor [] Nothing) 115 | -- , ("false", Ctor [] Nothing) 116 | -- ])) 117 | -- , Expr "foo" (Cse (Ref "true" 0 0) [] 118 | -- (M.fromList [("true",U64 1), ("false",U64 2)]) 119 | -- Nothing) 120 | -- ] 121 | -- ) 122 | --it "Bool" $ do 123 | -- parse' premodule 124 | -- "foo case true | true => 1 | false => 2 T Bool | true | false" `shouldBe` 125 | -- (Just $ 126 | -- [ Expr "foo" (Cse (Ref "true" 0 0) [] 127 | -- (M.fromList [("true",U64 1), ("false",U64 2)]) 128 | -- Nothing) 129 | -- , Data (ADT "Bool" [] [] 130 | -- (M.fromList 131 | -- [ ("true", Ctor [] Nothing) 132 | -- , ("false", Ctor [] Nothing) 133 | -- ])) 134 | -- ] 135 | -- ) 136 | -- parse' cse "case x | true => 1 | false => 0" `shouldBe` 137 | -- (Just $ Cse (Ref "x" 0) [] [("true", U64 1), ("false", U64 0)] Nothing) 138 | --it "\"as\" statement" $ do 139 | -- parse' cse "case x as y | true => 1 | false => 0" `shouldBe` 140 | -- (Just $ Cse (Ref "x" 0) [] [("true", U64 1), ("false", U64 0)] Nothing) 141 | --it "\"with\" statement" $ do 142 | -- parse' cse "case x with z with w | true => 1 | false => 0" `shouldBe` 143 | -- (Just $ 144 | -- Cse (Ref "x" 0) [("z",Ref "z" 0, Hol "#0"), ("w",Ref "w" 0, Hol "#1")] 145 | -- [ ("true", U64 1) 146 | -- , ("false", U64 0) 147 | -- ] Nothing) 148 | --it "`\"as\" and \"with\" statements" $ do 149 | -- parse' cse "case x as y with z with w | true => 1 | false => 0" `shouldBe` 150 | -- (Just $ 151 | -- Cse (Ref "x" 0) [("z",Ref "z" 0, Hol "#0"), ("w",Ref "w" 0, Hol "#1")] 152 | -- [ ("true", U64 1) 153 | -- , ("false", U64 0) 154 | -- ] Nothing) 155 | -- 156 | --it "case inside let" $ do 157 | -- parse' term "let P = (x : Bool) => case x | true => y | false => z w" 158 | -- `shouldBe` 159 | -- (Just $ 160 | -- Let (M.fromList 161 | -- [ ("P", Lam "x" (Ref "Bool" 0) Keep 162 | -- (Cse (Var 0) [] 163 | -- [ ("true",Ref "y" 0) 164 | -- , ("false",Ref "z" 0) 165 | -- ] Nothing)) 166 | -- ]) 167 | -- (Ref "w" 0)) 168 | -------------------------------------------------------------------------------- /test/Spec/Parser/Utils.hs: -------------------------------------------------------------------------------- 1 | module Spec.Parser.Utils where 2 | 3 | import Data.Text (Text) 4 | import qualified Data.Text as T 5 | 6 | import Text.Megaparsec hiding (State) 7 | import Text.Megaparsec.Char 8 | import qualified Text.Megaparsec.Char.Lexer as L 9 | 10 | import Control.Monad.RWS.Lazy hiding (All) 11 | import Parser 12 | 13 | parse' :: Show a => Parser a -> Text -> Maybe a 14 | parse' p s = either (const Nothing) (\(a, st, w) -> Just a) (parseDefault p s) 15 | --------------------------------------------------------------------------------