hakaru 0.4.0 → 0.6.0

raw patch · 76 files changed

+5442/−3710 lines, 76 filesdep +exact-combinatoricsdep +sybdep −ansi-terminaldep −hakarudep ~filepathdep ~transformers-compatnew-component:exe:prettyinternalPVP ok

version bump matches the API change (PVP)

Dependencies added: exact-combinatorics, syb

Dependencies removed: ansi-terminal, hakaru

Dependency ranges changed: filepath, transformers-compat

API changes (from Hackage documentation)

Files

• commands/Compile.hs +21/−37
• commands/Disintegrate.hs +4/−4
• commands/HKC.hs +5/−3
• commands/Hakaru.hs +25/−59
• commands/HkMaple.hs +86/−53
• commands/Mh.hs +28/−11
• commands/Pretty.hs +58/−8
• commands/PrettyInternal.hs +51/−0
• commands/Summary.hs +19/−34
• hakaru.cabal +101/−85
• haskell/Data/Number/Nat.hs +15/−5
• haskell/Data/Number/Natural.hs +12/−2
• haskell/Data/Text/Utf8.hs +0/−2
• haskell/Language/Hakaru/CodeGen/AST.hs +5/−4
• haskell/Language/Hakaru/CodeGen/CodeGenMonad.hs +122/−87
• haskell/Language/Hakaru/CodeGen/Flatten.hs +183/−156
• haskell/Language/Hakaru/CodeGen/Libs.hs +33/−1
• haskell/Language/Hakaru/CodeGen/Pretty.hs +20/−18
• haskell/Language/Hakaru/CodeGen/Types.hs +37/−9
• haskell/Language/Hakaru/CodeGen/Wrapper.hs +30/−20
• haskell/Language/Hakaru/Command.hs +43/−10
• haskell/Language/Hakaru/Disintegrate.hs +57/−22
• haskell/Language/Hakaru/Evaluation/DisintegrationMonad.hs +15/−5
• haskell/Language/Hakaru/Evaluation/ExpectMonad.hs +4/−2
• haskell/Language/Hakaru/Evaluation/Lazy.hs +19/−21
• haskell/Language/Hakaru/Evaluation/Types.hs +2/−4
• haskell/Language/Hakaru/Expect.hs +28/−6
• haskell/Language/Hakaru/Inference.hs +46/−20
• haskell/Language/Hakaru/Maple.hs +134/−29
• haskell/Language/Hakaru/Parser/AST.hs +132/−56
• haskell/Language/Hakaru/Parser/Import.hs +11/−9
• haskell/Language/Hakaru/Parser/Maple.hs +13/−4
• haskell/Language/Hakaru/Parser/Parser.hs +367/−276
• haskell/Language/Hakaru/Parser/SymbolResolve.hs +117/−30
• haskell/Language/Hakaru/Pretty/Concrete.hs +454/−459
• haskell/Language/Hakaru/Pretty/Haskell.hs +101/−21
• haskell/Language/Hakaru/Pretty/Maple.hs +17/−12
• haskell/Language/Hakaru/Pretty/SExpression.hs +316/−0
• haskell/Language/Hakaru/Runtime/CmdLine.hs +33/−15
• haskell/Language/Hakaru/Runtime/LogFloatCmdLine.hs +0/−74
• haskell/Language/Hakaru/Runtime/LogFloatPrelude.hs +62/−47
• haskell/Language/Hakaru/Runtime/Prelude.hs +21/−41
• haskell/Language/Hakaru/Sample.hs +116/−87
• haskell/Language/Hakaru/Simplify.hs +19/−4
• haskell/Language/Hakaru/Summary.hs +4/−3
• haskell/Language/Hakaru/Syntax/ABT.hs +17/−8
• haskell/Language/Hakaru/Syntax/AST.hs +23/−81
• haskell/Language/Hakaru/Syntax/AST/Eq.hs +67/−38
• haskell/Language/Hakaru/Syntax/AST/Sing.hs +3/−1
• haskell/Language/Hakaru/Syntax/AST/Transforms.hs +193/−15
• haskell/Language/Hakaru/Syntax/Command.hs +0/−80
• haskell/Language/Hakaru/Syntax/Datum.hs +4/−6
• haskell/Language/Hakaru/Syntax/DatumCase.hs +1/−3
• haskell/Language/Hakaru/Syntax/Hoist.hs +11/−2
• haskell/Language/Hakaru/Syntax/IClasses.hs +31/−4
• haskell/Language/Hakaru/Syntax/Prelude.hs +14/−7
• haskell/Language/Hakaru/Syntax/Reducer.hs +1/−1
• haskell/Language/Hakaru/Syntax/Rename.hs +0/−8
• haskell/Language/Hakaru/Syntax/SArgs.hs +91/−0
• haskell/Language/Hakaru/Syntax/Transform.hs +257/−0
• haskell/Language/Hakaru/Syntax/TypeCheck.hs +278/−549
• haskell/Language/Hakaru/Syntax/TypeCheck/TypeCheckMonad.hs +418/−0
• haskell/Language/Hakaru/Syntax/TypeCheck/Unification.hs +113/−0
• haskell/Language/Hakaru/Syntax/TypeOf.hs +8/−8
• haskell/Language/Hakaru/Syntax/Uniquify.hs +0/−1
• haskell/Language/Hakaru/Syntax/Value.hs +8/−10
• haskell/Language/Hakaru/Syntax/Variable.hs +17/−5
• haskell/Language/Hakaru/Types/Coercion.hs +2/−0
• haskell/Language/Hakaru/Types/HClasses.hs +9/−7
• haskell/Language/Hakaru/Types/Sing.hs +26/−3
• haskell/Tests/Parser.hs +18/−16
• haskell/Tests/Pretty.hs +98/−0
• haskell/Tests/Relationships.hs +369/−0
• haskell/Tests/RoundTrip.hs +242/−962
• haskell/Tests/TestSuite.hs +8/−8
• haskell/Tests/TestTools.hs +129/−32

@@ -17,8 +17,7 @@ import           Language.Hakaru.Syntax.TypeCheck  import           Language.Hakaru.Syntax.IClasses-import           Language.Hakaru.Types.Sing-import           Language.Hakaru.Types.DataKind+import           Language.Hakaru.Types.Sing (Sing(SFun, SMeasure))  import           Language.Hakaru.Pretty.Haskell import           Language.Hakaru.Command@@ -86,29 +85,29 @@  prettyProg :: (ABT T.Term abt)            => String+           -> Sing a            -> abt '[] a            -> String-prettyProg name ast =+prettyProg name typ ast =     renderStyle style-    (cat [ text (name ++ " = ")-         , nest 2 (pretty ast)-         ])+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )  compileHakaru     :: Options     -> IO () compileHakaru opts = do-    let file = fileIn opts-    prog <- readFromFile file+    let infile = fileIn opts+    prog <- readFromFile infile     case parseAndInfer prog of       Left err                 -> IO.hPutStrLn stderr err       Right (TypedAST typ ast) -> do         let ast' = (if optimize opts then optimizations else id) (et ast)-        writeHkHsToFile file (fileOut opts) . TxT.unlines $+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $           header (logFloatPrelude opts) (asModule opts) ++-          [ pack $ prettyProg "prog" ast' ] +++          [ pack $ prettyProg "prog" typ ast' ] ++           (case asModule opts of-             Nothing -> footer (logFloatPrelude opts) typ+             Nothing -> footer              Just _  -> [])   where et = expandTransformations @@ -128,8 +127,8 @@               | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)               -> writeHkHsToFile f1 (fileOut opts) . TxT.unlines $                    header (logFloatPrelude opts) (asModule opts) ++-                   [ pack $ prettyProg "prog1" (expandTransformations ast1) ] ++-                   [ pack $ prettyProg "prog2" (expandTransformations ast2) ] +++                   [ pack $ prettyProg "prog1" typ1 (expandTransformations ast1) ] +++                   [ pack $ prettyProg "prog2" typ2 (expandTransformations ast2) ] ++                    (case asModule opts of                       Nothing -> footerWalk                       Just _  -> [])@@ -155,14 +154,13 @@   , ""   , if logfloats     then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"-                     , "import           Prelude              hiding (product, exp, log, (**))"+                     , "import           Prelude hiding (product, exp, log, (**), pi)"+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"                      ]-    else "import           Prelude hiding (product)"-  , if logfloats-    then TxT.unlines [ "import           Language.Hakaru.Runtime.LogFloatPrelude"-                     , "import           Language.Hakaru.Runtime.LogFloatCmdLine" ]-    else TxT.unlines [ "import           Language.Hakaru.Runtime.Prelude"-                     , "import           Language.Hakaru.Runtime.CmdLine" ]+    else TxT.unlines [ "import           Prelude hiding (product)"+                     , "import           Language.Hakaru.Runtime.Prelude"+                     ]+  , "import           Language.Hakaru.Runtime.CmdLine"   , "import           Language.Hakaru.Types.Sing"   , "import qualified System.Random.MWC                as MWC"   , "import           Control.Monad"@@ -170,24 +168,10 @@   , ""   ] -footer :: forall (a :: Hakaru) . Bool -> Sing a -> [Text]-footer logfloats typ =+footer :: [Text]+footer =     ["","main :: IO ()"-    , TxT.concat ["main = makeMain (prog :: ",toHsType typ,")  =<< getArgs"]]-  where toHsType :: forall (a :: Hakaru) . Sing a -> Text-        toHsType SInt = "Int"-        toHsType SNat = "Int"-        toHsType SReal = "Double"-        toHsType SProb = if logfloats then "LogFloat" else "Double"-        toHsType (SArray t) = let t' = toHsType t in-                                TxT.concat ["(",TxT.unwords ["MayBoxVec",t',t'],")"]-        toHsType (SMeasure t) = TxT.concat ["(",TxT.unwords ["Measure",toHsType t],")"]-        toHsType (SFun t1 t2) = TxT.unwords [toHsType t1,"->",toHsType t2]-        toHsType (SData _-                   ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =-          TxT.concat ["(",toHsType t1,",",toHsType t2,")"]-        toHsType _ = "type"-+    , TxT.concat ["main = makeMain prog =<< getArgs"]]  footerWalk :: [Text] footerWalk =

@@ -65,8 +65,8 @@ main = do   args  <- parseOpts   case args of-    Options t i file -> do-      prog <- readFromFile file+    Options t i infile -> do+      prog <- readFromFile infile       runDisintegrate prog t i  runDisintegrate :: T.Text -> Bool -> Int -> IO ()@@ -99,13 +99,13 @@               _ -> putErrorMsg ast                     putErrorMsg :: (Show a) => a -> IO ()-putErrorMsg a = IO.hPutStrLn stderr . T.pack $+putErrorMsg _ = IO.hPutStrLn stderr . T.pack $                 "Can only disintegrate (functions over) measures over pairs"                 -- ++ "\nGiven\n" ++ show a  -- | Use a list of variables to wrap lambdas around a given term lams :: (ABT AST.Term abt)      => List1 Variable (xs :: [Hakaru])-     -> (forall a. abt '[] a -> IO ()) -> abt '[] a -> IO ()+     -> (forall b. abt '[] b -> IO ()) -> abt '[] a -> IO () lams Nil1         k = k lams (Cons1 x xs) k = lams xs (k . lam_ x)

@@ -40,7 +40,7 @@          , asFunc           :: Maybe String          , fileIn           :: String          , fileOut          :: Maybe String-         , par              :: Bool+         , par              :: Bool -- turns on simd and sharedMem          , noWeightsOpt     :: Bool          , showProbInLogOpt :: Bool          , garbageCollector :: Bool@@ -77,7 +77,7 @@                             <> metavar "OUTPUT"                             <> help "output FILE"))   <*> switch (  short 'j'-             <> help "Generates parallel programs using OpenMP directives")+             <> help "Generates multithreaded and simd parallel programs using OpenMP directives")   <*> switch (  long "no-weights"              <> short 'w'              <> help "Don't print the weights")@@ -110,7 +110,9 @@                                 (asFunc config)                                 (PrintConfig { noWeights     = noWeightsOpt config                                              , showProbInLog = showProbInLogOpt config })-          codeGenConfig = emptyCG {sharedMem = par config, managedMem = garbageCollector config}+          codeGenConfig = emptyCG { sharedMem = par config+                                  , simd      = par config+                                  , managedMem = garbageCollector config}           cast    = CAST $ runCodeGenWith codeGen codeGenConfig           output  = pack . render . pretty $ cast       when (debug config) $ do

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP-           , OverloadedStrings+{-# LANGUAGE OverloadedStrings            , PatternGuards            , DataKinds            , GADTs@@ -10,25 +9,23 @@  import           Language.Hakaru.Syntax.AST.Transforms import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Syntax.TypeCheck.Unification import           Language.Hakaru.Syntax.Value -import           Language.Hakaru.Syntax.IClasses import           Language.Hakaru.Types.Sing import           Language.Hakaru.Types.DataKind  import           Language.Hakaru.Sample import           Language.Hakaru.Pretty.Concrete-import           Language.Hakaru.Command ( parseAndInfer, parseAndInfer'-                                         , readFromFile, Term+import           Language.Hakaru.Command ( parseAndInfer'+                                         , readFromFile', Term, Source+                                         , sourceInput                                          ) -#if __GLASGOW_HASKELL__ < 710-import           Control.Applicative   (Applicative(..), (<$>))-#endif+import           Control.Applicative   (Applicative(..), (<$>), liftA2) import           Control.Monad  import           Data.Monoid-import           Data.Text import qualified Data.Text.IO as IO import qualified Data.Vector  as V import           Data.Word@@ -73,10 +70,10 @@               Nothing -> MWC.createSystemRandom               Just s  -> MWC.initialize (V.singleton s)   case transition args of-      Nothing    -> runHakaru' g (noWeights args) =<< readFromFile (prog args)-      Just prog2 -> do prog' <- readFromFile (prog args)-                       trans <- readFromFile prog2-                       randomWalk' g trans prog'+      Nothing    -> runHakaru g (noWeights args) =<< readFromFile' (prog args)+      Just prog2 -> do prog' <- readFromFile' (prog args)+                       trans <- readFromFile' prog2+                       randomWalk g trans prog'  -- TODO: A better needs to be found for passing weights around illustrate :: Sing a -> Bool -> MWC.GenIO -> Value a -> IO ()@@ -98,22 +95,9 @@ renderLn = putStrLn . renderStyle style {mode = LeftMode} . prettyValue  -- TODO: A better needs to be found for passing weights around-runHakaru :: MWC.GenIO -> Bool -> Text -> IO ()-runHakaru g weights prog' =-    case parseAndInfer prog' of-      Left err                 -> IO.hPutStrLn stderr err-      Right (TypedAST typ ast) -> do-        case typ of-          SMeasure _ -> forever (illustrate typ weights g $ run ast)-          _          -> illustrate typ weights g $ run ast-    where-    run :: Term a -> Value a-    run = runEvaluate . expandTransformations---- TODO: A better needs to be found for passing weights around-runHakaru' :: MWC.GenIO -> Bool -> Text -> IO ()-runHakaru' g weights prog = do-    prog' <- parseAndInfer' prog+runHakaru :: MWC.GenIO -> Bool -> Source -> IO ()+runHakaru g weights progname = do+    prog' <- parseAndInfer' progname     case prog' of       Left err                 -> IO.hPutStrLn stderr err       Right (TypedAST typ ast) -> do@@ -124,40 +108,22 @@     run :: Term a -> Value a     run = runEvaluate . expandTransformations -randomWalk :: MWC.GenIO -> Text -> Text -> IO ()-randomWalk g p1 p2 =-    case (parseAndInfer p1, parseAndInfer p2) of-      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->-          -- TODO: Use better error messages for type mismatch-          case (typ1, typ2) of-            (SFun a (SMeasure b), SMeasure c)-              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)-              -> iterateM_ (chain $ run ast1) (run ast2)-            _ -> IO.hPutStrLn stderr "hakaru: programs have wrong type"-      (Left err, _) -> IO.hPutStrLn stderr err-      (_, Left err) -> IO.hPutStrLn stderr err-    where-    run :: Term a -> Value a-    run = runEvaluate . expandTransformations--    chain :: Value (a ':-> b) -> Value ('HMeasure a) -> IO (Value b)-    chain (VLam f) (VMeasure m) = do-      Just (samp,_) <- m (VProb 1) g-      renderLn samp-      return (f samp)--randomWalk' :: MWC.GenIO -> Text -> Text -> IO ()-randomWalk' g p1 p2 = do+randomWalk :: MWC.GenIO -> Source -> Source -> IO ()+randomWalk g p1 p2 = do+    let inp = foldl1 (liftA2 (V.++)) $ map sourceInput [p1,p2]     p1' <- parseAndInfer' p1     p2' <- parseAndInfer' p2     case (p1', p2') of       (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->-          -- TODO: Use better error messages for type mismatch-          case (typ1, typ2) of-            (SFun a (SMeasure b), SMeasure c)-              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)-              -> iterateM_ (chain $ run ast1) (run ast2)-            _ -> IO.hPutStrLn stderr "hakaru: programs have wrong type"+        let check =+              unifyFun typ1 Nothing $ \a mb ->+              unifyMeasure mb Nothing $ \b ->+              unifyMeasure typ2 Nothing $ \c ->+              matchTypes a b Nothing (SFun a (SMeasure a)) typ1 $+              matchTypes b c Nothing mb typ2 $+              return $ iterateM_ (chain $ run ast1) (run ast2)+        in either (IO.hPutStrLn stderr) id $+           runTCM check inp LaxMode       (Left err, _) -> IO.hPutStrLn stderr err       (_, Left err) -> IO.hPutStrLn stderr err     where

@@ -8,58 +8,62 @@  module Main where -import           Language.Hakaru.Pretty.Concrete  +import           Language.Hakaru.Pretty.Concrete as C+import           Language.Hakaru.Pretty.SExpression as S+import           Language.Hakaru.Pretty.Haskell as H import           Language.Hakaru.Syntax.AST.Transforms import           Language.Hakaru.Syntax.TypeCheck-import           Language.Hakaru.Command (parseAndInfer, readFromFile, Term)+import           Language.Hakaru.Command (parseAndInfer', readFromFile')  import           Language.Hakaru.Syntax.Rename-import           Language.Hakaru.Simplify-import           Language.Hakaru.Maple -import           Language.Hakaru.Parser.Maple +import           Language.Hakaru.Maple +import           Language.Hakaru.Syntax.Transform (Transform(..)+                                                  ,someTransformations)+import           Language.Hakaru.Syntax.IClasses (Some2(..))  #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative   (Applicative(..), (<$>)) #endif -import           Data.Monoid ((<>), mconcat)-import           Data.Text (Text, unpack, pack)-import qualified Data.Text as Text -import qualified Data.Text.IO as IO+import           Data.Monoid ((<>), Monoid(..))+import qualified Data.Text as Text+import qualified Data.Text.Utf8 as IO import           System.IO (stderr)-import           Data.List (intercalate) +import           Data.List (intercalate) import           Text.Read (readMaybe) import           Control.Exception(throw) import qualified Options.Applicative as O-import qualified Data.Map as M +import qualified Data.Map as M  -data Options a +data Options a   = Options-    { moptions      :: MapleOptions String+    { moptions      :: MapleOptions (Maybe String)     , no_unicode    :: Bool-    , program       :: a } -  | ListCommands +    , toExpand      :: Maybe [Some2 Transform]+    , printer       :: String+    , program       :: a }+  | ListCommands+  | PrintVersion  -parseKeyVal :: O.ReadM (String, String) -parseKeyVal = -  O.maybeReader $ (\str -> -    case map Text.strip $ Text.splitOn "," str of -      [k,v] -> return (unpack k, unpack v)-      _     -> Nothing) . pack +parseKeyVal :: O.ReadM (String, String)+parseKeyVal =+  O.maybeReader $ (\str ->+    case map Text.strip $ Text.splitOn "," str of+      [k,v] -> return (Text.unpack k, Text.unpack v)+      _     -> Nothing) . Text.pack  options :: O.Parser (Options FilePath) options = (Options-  <$> (MapleOptions <$> -        O.option O.str+  <$> (MapleOptions <$>+        O.option (O.maybeReader (Just . Just))         ( O.long "command" <>           O.help ("Command to send to Maple. You may enter a prefix of the command string if "-                 ++"it uniquely identifies a command. "-                 ++"Default: Simplify") <>-          O.short 'c' <> -          O.value "Simplify" ) +                 ++"it uniquely identifies a command. ") <>+          O.short 'c' <>+          O.value Nothing )     <*> O.switch         ( O.long "debug" <>           O.help "Prints output that is sent to Maple." )@@ -69,31 +73,45 @@           O.showDefault <>           O.value 90 <>           O.metavar "N")-    <*> (M.fromList <$> +    <*> (M.fromList <$>           O.many (O.option parseKeyVal-        ( O.long "maple-opt" <> -          O.short 'm' <> +        ( O.long "maple-opt" <>+          O.short 'm' <>           O.help ( "Extra options to send to Maple\neach options is of the form KEY=VAL\n"                  ++"where KEY is a Maple name, and VAL is a Maple expression.")-        ))))-  <*> O.switch -      ( O.long "no-unicode" <> -        O.short 'u' <> +        )))+    <*> pure mempty)+  <*> O.switch+      ( O.long "no-unicode" <>+        O.short 'u' <>         O.help "Removes unicode characters from names in the Maple output.")+  <*> O.option (O.maybeReader $ fmap (fmap Just) readMaybe)+      ( O.short 'e' <>+        O.long "to-expand" <>+        O.value Nothing <>+        O.help "Transformations to be expanded; default is all transformations" )+  <*> O.strOption+      ( O.short 'p' <>+        O.long "printer" <>+        O.value "concrete" )   <*> O.strArgument-      ( O.metavar "PROGRAM" <> -        O.help "Filename containing program to be simplified, or \"-\" to read from input." )) O.<|> -  ( O.flag' ListCommands  +      ( O.metavar "PROGRAM" <>+        O.help "Filename containing program to be simplified, or \"-\" to read from input." )) O.<|>+  ( O.flag' ListCommands       ( O.long "list-commands" <>         O.help "Get list of available commands from Maple." <>-        O.short 'l') )+        O.short 'l') ) O.<|>+  ( O.flag' PrintVersion+      ( O.long "version" <>+        O.help "Prints the version of the Hakaru Maple library." <>+        O.short 'v') )  parseOpts :: IO (Options FilePath) parseOpts = O.execParser $ O.info (O.helper <*> options)       (O.fullDesc <> O.progDesc progDesc) -progDesc :: String -progDesc = unwords  +progDesc :: String+progDesc = unwords   ["hk-maple: invokes a Maple command on a Hakaru program. "   ,"Given a Hakaru program in concrete syntax and a Maple-Hakaru command,"   ,"typecheck the program"@@ -101,28 +119,43 @@   ,"pretty print, parse and typecheck the program resulting from Maple"   ] -et (TypedAST t (x :: Term a)) = TypedAST t (expandTransformations x)- main :: IO () main = parseOpts >>= runMaple  runMaple :: Options FilePath -> IO ()-runMaple ListCommands = +runMaple ListCommands =   listCommands >>= \cs -> putStrLn $ "Available Hakaru Maple commands:\n\t"++ intercalate ", " cs -runMaple Options{..} = readFromFile program >>= \prog -> -  case parseAndInfer prog of+runMaple PrintVersion = printVersion++runMaple Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->+  case prog of     Left  err  -> IO.hPutStrLn stderr err-    Right ast  -> do -      TypedAST _ ast' <- sendToMaple' moptions (et ast)-      print $ pretty -            $ (if no_unicode then renameAST removeUnicodeChars else id) +    Right ast  -> do+      let et = onTypedASTM $ expandTransformationsWith $+                (maybe id someTransformations toExpand)+                (allTransformationsWithMOpts moptions{command=()})+      TypedAST typ ast' <-+        (case command moptions of+           Just c  -> sendToMaple' moptions{command=c}+           Nothing -> return) =<< et ast+      IO.print+            $ (case printer of+                 "concrete" -> C.pretty+                 "sexpression" -> S.pretty+                 "haskell" -> H.prettyString typ+                 _ -> error "Invalid printer requested")+            $ (if no_unicode then renameAST removeUnicodeChars else id)             $ ast' -listCommands :: IO [String] -listCommands = do +listCommands :: IO [String]+listCommands = do     let toMaple_ = "use Hakaru, NewSLO in lprint(map(curry(sprintf,`%s`),NewSLO:-Commands)) end use;"     fromMaple <- maple toMaple_     maybe (throw $ MapleInterpreterException fromMaple toMaple_)-          return -          (readMaybe fromMaple) +          return+          (readMaybe fromMaple)++printVersion :: IO ()+printVersion =+  maple "use Hakaru, NewSLO in NewSLO:-PrintVersion() end use;" >>= putStr

@@ -1,4 +1,11 @@-{-# LANGUAGE OverloadedStrings, PatternGuards, DataKinds, GADTs #-}+{-# LANGUAGE OverloadedStrings+           , PatternGuards+           , DataKinds+           , GADTs+           , KindSignatures+           , RankNTypes+           , TypeOperators+           , FlexibleContexts #-}  module Main where @@ -6,9 +13,11 @@ import           Language.Hakaru.Syntax.TypeCheck  import           Language.Hakaru.Syntax.IClasses-import           Language.Hakaru.Types.Sing-import           Language.Hakaru.Inference-import           Language.Hakaru.Command+import           Language.Hakaru.Syntax.ABT (ABT(..), dupABT)+import           Language.Hakaru.Syntax.AST (Term(..), Transform(..))+import           Language.Hakaru.Syntax.AST.Transforms (expandTransformations)+import qualified Language.Hakaru.Parser.AST as U+import           Language.Hakaru.Command hiding (Term)    import           Data.Text import qualified Data.Text.IO as IO@@ -27,12 +36,20 @@ runMH :: Text -> Text -> IO () runMH prog1 prog2 =     case (parseAndInfer prog1, parseAndInfer prog2) of-      (Right (TypedAST typ1 ast1), Right (TypedAST typ2 ast2)) ->-          -- TODO: Use better error messages for type mismatch-          case (typ1, typ2) of-            (SFun a (SMeasure b), SMeasure c)-              | (Just Refl, Just Refl) <- (jmEq1 a b, jmEq1 b c)-              -> print . pretty $ mcmc ast1 ast2-            _ -> IO.hPutStrLn stderr "mh: programs have wrong type"+      (Right (TypedAST _ ast1), Right (TypedAST _ ast2)) ->+         either (IO.hPutStrLn stderr)+                (elimTypedAST $ \_ -> print . pretty) $+         runMH' ast1 ast2       (Left err, _) -> IO.hPutStrLn stderr err       (_, Left err) -> IO.hPutStrLn stderr err++runMH' :: (ABT Term abt)+       => abt '[] a+       -> abt '[] b+       -> Either Text (TypedAST abt)+runMH' prop tgt =+  let uast = syn $ U.Transform_ MCMC $+               (Nil2, syn $ U.InjTyped $ dupABT prop) U.:*+               (Nil2, syn $ U.InjTyped $ dupABT tgt ) U.:* U.End+  in do TypedAST rty res <- runTCM (inferType uast) Nothing LaxMode+        return $ TypedAST rty $ expandTransformations res

@@ -1,22 +1,72 @@-{-# LANGUAGE OverloadedStrings, DataKinds, GADTs #-}+{-# LANGUAGE OverloadedStrings+           , DataKinds+           , GADTs+           , CPP+           , RecordWildCards+           #-}  module Main where  import           Language.Hakaru.Pretty.Concrete import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.Transform (Transform(..)+                                                  ,someTransformations)+import           Language.Hakaru.Syntax.IClasses (Some2(..)) import           Language.Hakaru.Syntax.TypeCheck import           Language.Hakaru.Command -import           Data.Text+import qualified Data.Text as T  import qualified Data.Text.Utf8 as IO import           System.IO (stderr)+import           Data.Monoid +#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative   (Applicative(..), (<$>), (<*>))+#endif+import qualified Options.Applicative as O++data Options = Options+  { printType :: Bool +  , program   :: FilePath +  , toExpand  :: [Some2 Transform]+  }++options :: O.Parser Options+options = Options+  <$> O.switch+      ( O.short 't' <>+        O.long "print-type" <>+        O.help "Annotate the program with its type." )+  <*> O.strArgument+      ( O.metavar "PROGRAM" <> +        O.help "Filename containing program to be pretty printed, or \"-\" to read from input." ) +  <*> O.option O.auto+      ( O.short 'e' <>+        O.long "to-expand" <>+        O.value [Some2 Expect, Some2 Observe] <>+        O.help "Transformations to be expanded; default [Expect, Observe]" )++parseOpts :: IO Options+parseOpts = O.execParser $ O.info (O.helper <*> options)+      (O.fullDesc <> O.progDesc "Parse, typecheck, and pretty print a Hakaru program")+ main :: IO ()-main = simpleCommand runPretty "pretty"+main = parseOpts >>= runPretty  -runPretty :: Text -> IO ()-runPretty prog =-    case parseAndInfer prog of-    Left  err              -> IO.hPutStrLn stderr err-    Right (TypedAST _ ast) -> IO.print . pretty . expandTransformations $ ast+runPretty :: Options -> IO ()+runPretty Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->+    case prog of+    Left  err                -> IO.hPutStrLn stderr err+    Right (TypedAST typ ast) -> IO.putStrLn . T.pack $+      let et = expandTransformationsWith'+                 (someTransformations toExpand haskellTransformations)+          concreteProgram = show . pretty . et $ ast+          withType t x = concat [ "(", x, ")"+                                , "\n.\n"+                                , show (prettyType 12 t)+                                ] in++      if printType then+          withType typ concreteProgram+      else concreteProgram 

@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings, DataKinds, GADTs, CPP, RecordWildCards #-}++module Main where++import           Language.Hakaru.Syntax.AST.Transforms+import           Language.Hakaru.Syntax.TypeCheck+import           Language.Hakaru.Command++import qualified Data.Text as T+import qualified Data.Text.Utf8 as IO+import           System.IO (stderr)+import           Data.Monoid++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative   (Applicative(..), (<$>), (<*>))+#endif+import qualified Options.Applicative as O++data Options = Options+  { printType :: Bool +  , program   :: FilePath +  }++options :: O.Parser Options+options = Options+  <$> O.switch+      ( O.short 't' <>+        O.long "print-type" <>+        O.help "Print the type of the program as well." )+  <*> O.strArgument+      ( O.metavar "PROGRAM" <> +        O.help "Filename containing program to be printed, or \"-\" to read from input." ) ++parseOpts :: IO Options+parseOpts = O.execParser $ O.info (O.helper <*> options)+      (O.fullDesc <> O.progDesc "Parse, typecheck, and print (in internal syntax) a Hakaru program")++main :: IO ()+main = parseOpts >>= runPretty ++runPretty :: Options -> IO ()+runPretty Options{..} = readFromFile' program >>= parseAndInfer' >>= \prog ->+    case prog of+    Left  err               -> IO.hPutStrLn stderr err+    Right (TypedAST ty ast) -> IO.putStrLn $+      -- TODO: prettier (than `show') printing of internal syntax+      (if printType then \x ->+          T.concat [ "(", x, ")"+                   , "\n.\n" <> T.pack (show ty) ]+       else id)+      (T.pack $ show $ expandTransformations ast)

@@ -15,8 +15,7 @@ import           Language.Hakaru.Syntax.ABT import           Language.Hakaru.Syntax.TypeCheck -import           Language.Hakaru.Types.Sing-import           Language.Hakaru.Types.DataKind+import           Language.Hakaru.Types.Sing (Sing)  import           Language.Hakaru.Pretty.Haskell import           Language.Hakaru.Command@@ -79,29 +78,29 @@  prettyProg :: (ABT T.Term abt)            => String+           -> Sing a            -> abt '[] a            -> String-prettyProg name ast =+prettyProg name typ ast =     renderStyle style-    (cat [ text (name ++ " = ")-         , nest 2 (pretty ast)-         ])+    (    sep [text (name ++ " ::"), nest 2 (prettyType typ)]+     $+$ sep [text (name ++ " =") , nest 2 (pretty     ast)] )  compileHakaru     :: Options     -> IO () compileHakaru opts = do-    let file = fileIn opts-    prog <- readFromFile file+    let infile = fileIn opts+    prog <- readFromFile infile     case parseAndInfer prog of       Left err                 -> IO.hPutStrLn stderr err       Right (TypedAST typ ast) -> do         ast' <- (if optimize opts then optimizations else id) <$> summary (et ast)-        writeHkHsToFile file (fileOut opts) . TxT.unlines $+        writeHkHsToFile infile (fileOut opts) . TxT.unlines $           header (logFloatPrelude opts) (asModule opts) ++-          [ pack $ prettyProg "prog" ast' ] +++          [ pack $ prettyProg "prog" typ ast' ] ++           (case asModule opts of-             Nothing -> footer typ+             Nothing -> footer              Just _  -> [])   where et = expandTransformations @@ -123,14 +122,13 @@   , ""   , if logfloats     then TxT.unlines [ "import           Data.Number.LogFloat (LogFloat)"-                     , "import           Prelude              hiding (product, exp, log, (**))"+                     , "import           Prelude hiding (product, exp, log, (**), pi)"+                     , "import           Language.Hakaru.Runtime.LogFloatPrelude"                      ]-    else "import           Prelude hiding (product)"-  , if logfloats-    then TxT.unlines [ "import           Language.Hakaru.Runtime.LogFloatPrelude"-                     , "import           Language.Hakaru.Runtime.LogFloatCmdLine" ]-    else TxT.unlines [ "import           Language.Hakaru.Runtime.Prelude"-                     , "import           Language.Hakaru.Runtime.CmdLine" ]+    else TxT.unlines [ "import           Prelude hiding (product)"+                     , "import           Language.Hakaru.Runtime.Prelude"+                     ]+  , "import           Language.Hakaru.Runtime.CmdLine"   , "import           Language.Hakaru.Types.Sing"   , "import qualified System.Random.MWC                as MWC"   , "import           Control.Monad"@@ -138,23 +136,10 @@   , ""   ] -footer :: Sing (a :: Hakaru) -> [Text]-footer typ =+footer :: [Text]+footer =     ["","main :: IO ()"-    , TxT.concat ["main = makeMain (prog :: ",toHsType typ,")  =<< getArgs"]]-  where toHsType :: Sing (a :: Hakaru) -> Text-        toHsType SInt = "Int"-        toHsType SNat = "Int"-        toHsType SReal = "Double"-        toHsType SProb = "LogFloat"-        toHsType (SArray t) = let t' = toHsType t in-                                TxT.concat ["(",TxT.unwords ["MayBoxVec",t',t'],")"]-        toHsType (SMeasure t) = TxT.concat ["(",TxT.unwords ["Measure",toHsType t],")"]-        toHsType (SFun t1 t2) = TxT.unwords [toHsType t1,"->",toHsType t2]-        toHsType (SData _-                   ((SKonst t1 `SEt` SKonst t2 `SEt` SDone) `SPlus` SVoid)) =-          TxT.concat ["(",toHsType t1,",",toHsType t2,")"]-        toHsType _ = "type"+    , TxT.concat ["main = makeMain prog =<< getArgs"]]  footerWalk :: [Text] footerWalk =

@@ -3,11 +3,11 @@ cabal-version:       >=1.16 build-type:          Simple name:                hakaru-version:             0.4.0+version:             0.6.0 synopsis:            A probabilistic programming language description:         Hakaru is a simply-typed probabilistic programming language, designed                      for easy specification of probabilistic models, and inference algorithms.-homepage:            http://indiana.edu/~ppaml/+homepage:            http://hakaru-dev.github.io/ license:             BSD3 license-file:        LICENSE author:              The Hakaru Team@@ -30,7 +30,7 @@ Library     Hs-Source-Dirs:    haskell     Default-Language:  Haskell2010-    GHC-Options:       -Wall -fwarn-tabs -j6+    GHC-Options:       -Wall -fwarn-tabs -j6       if flag(traceDisintegrate)         Cpp-Options:   -D__TRACE_DISINTEGRATE__@@ -48,33 +48,36 @@                        Language.Hakaru.Types.HClasses,                        Language.Hakaru.Types.Coercion,                        Language.Hakaru.Syntax.ANF,-                       Language.Hakaru.Syntax.Uniquify,-                       Language.Hakaru.Syntax.Unroll,                        Language.Hakaru.Syntax.AST,-                       Language.Hakaru.Syntax.AST.Transforms,-                       Language.Hakaru.Syntax.AST.Sing,                        Language.Hakaru.Syntax.AST.Eq,-                       Language.Hakaru.Syntax.Command,+                       Language.Hakaru.Syntax.AST.Sing,+                       Language.Hakaru.Syntax.AST.Transforms,                        Language.Hakaru.Syntax.CSE,                        Language.Hakaru.Syntax.Gensym,-                       Language.Hakaru.Syntax.Rename,                        Language.Hakaru.Syntax.Hoist,+                       Language.Hakaru.Syntax.Prelude,                        Language.Hakaru.Syntax.Prune,+                       Language.Hakaru.Syntax.Rename,+                       Language.Hakaru.Syntax.SArgs,+                       Language.Hakaru.Syntax.Transform,                        Language.Hakaru.Syntax.TypeCheck,+                       Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad,+                       Language.Hakaru.Syntax.TypeCheck.Unification,                        Language.Hakaru.Syntax.TypeOf,-                       Language.Hakaru.Syntax.Prelude,+                       Language.Hakaru.Syntax.Uniquify,+                       Language.Hakaru.Syntax.Unroll,                        Language.Hakaru.Parser.AST,                        Language.Hakaru.Parser.Maple,                        Language.Hakaru.Parser.Import,                        Language.Hakaru.Parser.Parser,                        Language.Hakaru.Parser.SymbolResolve,                        Language.Hakaru.Pretty.Haskell,+                       Language.Hakaru.Pretty.SExpression,                        Language.Hakaru.Pretty.Concrete,                        Language.Hakaru.Pretty.Maple,                        Language.Hakaru.Runtime.Prelude,                        Language.Hakaru.Runtime.LogFloatPrelude,                        Language.Hakaru.Runtime.CmdLine,-                       Language.Hakaru.Runtime.LogFloatCmdLine,                        Language.Hakaru.Observe,                        Language.Hakaru.Maple,                        Language.Hakaru.Simplify,@@ -105,31 +108,32 @@      other-modules:     System.MapleSSH -    build-depends:     base               >= 4.7  && < 5.0,-                       Cabal              >= 1.16,-                       ghc-prim           >= 0.3  && < 0.6,-                       transformers       >= 0.3  && < 0.6,-                       transformers-compat >= 0.3  && < 0.6,-                       containers         >= 0.5  && < 0.6,-                       semigroups         >= 0.16,-                       pretty             >= 1.1  && < 1.2,-                       logfloat           >= 0.13 && < 0.14,-                       math-functions     >= 0.1  && < 0.3,-                       vector             >= 0.10,-                       indentation-parsec >= 0.0,-                       ansi-terminal      >= 0.6,-                       text               >= 0.11 && < 1.3,-                       parsec             >= 3.1  && < 3.2,-                       mwc-random         >= 0.13 && < 0.14,-                       directory          >= 1.2  && < 1.4,-                       integration        >= 0.2.0 && < 0.3.0,-                       primitive          >= 0.5  && < 0.7,-                       process            >= 1.1  && < 2.0,-                       HUnit              >= 1.2  && < 2.0,-                       mtl                >= 2.1,-                       filepath           >= 1.1.0.2, -                       bytestring         >= 0.9, -                       optparse-applicative >= 0.11 && < 0.15+    build-depends:     base                 >= 4.7  && < 5.0,+                       Cabal                >= 1.16,+                       ghc-prim             >= 0.3  && < 0.6,+                       transformers         >= 0.3  && < 0.6,+                       transformers-compat  >= 0.3  && < 0.7,+                       containers           >= 0.5  && < 0.6,+                       semigroups           >= 0.16,+                       pretty               >= 1.1  && < 1.2,+                       logfloat             >= 0.13 && < 0.14,+                       math-functions       >= 0.1  && < 0.3,+                       vector               >= 0.10,+                       indentation-parsec   >= 0.0,+                       text                 >= 0.11 && < 1.3,+                       parsec               >= 3.1  && < 3.2,+                       mwc-random           >= 0.13 && < 0.14,+                       directory            >= 1.2  && < 1.4,+                       integration          >= 0.2.0 && < 0.3.0,+                       primitive            >= 0.5  && < 0.7,+                       process              >= 1.1  && < 2.0,+                       HUnit                >= 1.2  && < 2.0,+                       mtl                  >= 2.1,+                       filepath             >= 1.1.0.2,+                       bytestring           >= 0.9,+                       optparse-applicative >= 0.11 && < 0.15,+                       syb                  >= 0.6,+                       exact-combinatorics  >= 0.2.0  ---------------------------------------------------------------- Test-Suite system-testsuite@@ -138,7 +142,7 @@     Hs-Source-Dirs:    haskell     Default-Language:  Haskell2010     GHC-Options:       -Wall -fwarn-tabs-	+     other-modules:     Data.Number.Nat                        Data.Number.Natural                        Data.Text.Utf8@@ -154,6 +158,7 @@                        Language.Hakaru.Evaluation.Types                        Language.Hakaru.Expect                        Language.Hakaru.Inference+                       Language.Hakaru.Maple                        Language.Hakaru.Parser.AST                        Language.Hakaru.Parser.Import                        Language.Hakaru.Parser.Maple@@ -168,6 +173,7 @@                        Language.Hakaru.Syntax.ANF                        Language.Hakaru.Syntax.AST                        Language.Hakaru.Syntax.AST.Eq+                       Language.Hakaru.Syntax.AST.Transforms                        Language.Hakaru.Syntax.AST.Sing                        Language.Hakaru.Syntax.CSE                        Language.Hakaru.Syntax.Datum@@ -179,7 +185,11 @@                        Language.Hakaru.Syntax.Prelude                        Language.Hakaru.Syntax.Prune                        Language.Hakaru.Syntax.Reducer+                       Language.Hakaru.Syntax.SArgs+                       Language.Hakaru.Syntax.Transform                        Language.Hakaru.Syntax.TypeCheck+                       Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad+                       Language.Hakaru.Syntax.TypeCheck.Unification                        Language.Hakaru.Syntax.TypeOf                        Language.Hakaru.Syntax.Uniquify                        Language.Hakaru.Syntax.Unroll@@ -194,36 +204,40 @@                        Tests.Disintegrate                        Tests.Models                        Tests.Parser+                       Tests.Pretty+                       Tests.Relationships                        Tests.RoundTrip                        Tests.Sample                        Tests.Simplify                        Tests.TestTools                        Tests.TypeCheck -    Build-Depends:     base               >= 4.6  && < 5.0,-                       Cabal              >= 1.16,-                       ghc-prim           >= 0.3  && < 0.6,-                       indentation-parsec >= 0.0,-                       transformers       >= 0.3  && < 0.6,-                       containers         >= 0.5  && < 0.6,-                       semigroups         >= 0.16,-                       logfloat           >= 0.13 && < 0.14,-                       parsec             >= 3.1  && < 3.2,-                       primitive          >= 0.5  && < 0.7,-                       pretty             >= 1.1  && < 1.2,-                       mwc-random         >= 0.13 && < 0.14,-                       math-functions     >= 0.1  && < 0.3,-                       integration        >= 0.2  && < 0.3,-                       ansi-terminal      >= 0.6,-                       HUnit              >= 1.2  && < 2.0,-                       QuickCheck         >= 2.6,-                       process            >= 1.1  && < 2.0,-                       mtl                >= 2.1,-                       vector             >= 0.10,-                       text               >= 0.11 && < 1.3, -                       bytestring         >= 0.9, -                       directory          >= 1.2  && < 1.4,-                       optparse-applicative >= 0.11 && < 0.15+    build-depends:     base                 >= 4.6  && < 5.0,+                       Cabal                >= 1.16,+                       ghc-prim             >= 0.3  && < 0.6,+                       indentation-parsec   >= 0.0,+                       transformers         >= 0.3  && < 0.6,+                       containers           >= 0.5  && < 0.6,+                       semigroups           >= 0.16,+                       logfloat             >= 0.13 && < 0.14,+                       parsec               >= 3.1  && < 3.2,+                       primitive            >= 0.5  && < 0.7,+                       pretty               >= 1.1  && < 1.2,+                       mwc-random           >= 0.13 && < 0.14,+                       math-functions       >= 0.1  && < 0.3,+                       integration          >= 0.2  && < 0.3,+                       HUnit                >= 1.2  && < 2.0,+                       QuickCheck           >= 2.6,+                       process              >= 1.1  && < 2.0,+                       mtl                  >= 2.1,+                       vector               >= 0.10,+                       text                 >= 0.11 && < 1.3,+                       bytestring           >= 0.9,+                       directory            >= 1.2  && < 1.4,+                       optparse-applicative >= 0.11 && < 0.15,+                       syb                  >= 0.6,+                       filepath             >= 1.1.0.2,+                       exact-combinatorics  >= 0.2.0  ---------------------------------------------------------------- Executable hakaru@@ -237,8 +251,7 @@                        text                 >= 0.11 && < 1.3,                        pretty               >= 1.1  && < 1.2,                        vector               >= 0.10,-                       optparse-applicative >= 0.11 && < 0.15,-                       hakaru               >= 0.3+                       optparse-applicative >= 0.11 && < 0.15  ---------------------------------------------------------------- Executable compile@@ -252,8 +265,7 @@                        text                 >= 0.11 && < 1.3,                        pretty               >= 1.1  && < 1.2,                        filepath             >= 1.3,-                       optparse-applicative >= 0.11 && < 0.15,-                       hakaru               >= 0.3+                       optparse-applicative >= 0.11 && < 0.15  ---------------------------------------------------------------- Executable summary@@ -267,8 +279,7 @@                        text                 >= 0.11 && < 1.3,                        pretty               >= 1.1  && < 1.2,                        filepath             >= 1.3,-                       optparse-applicative >= 0.11 && < 0.15,-                       hakaru               >= 0.3+                       optparse-applicative >= 0.11 && < 0.15  ---------------------------------------------------------------- Executable hk-maple@@ -282,8 +293,7 @@                        text                 >= 0.11 && < 1.3,                        pretty               >= 1.1  && < 1.2,                        optparse-applicative >= 0.13 && < 0.15,-                       containers           >= 0.5  && < 0.6,-                       hakaru               >= 0.3+                       containers           >= 0.5  && < 0.6  ---------------------------------------------------------------- Executable density@@ -295,8 +305,7 @@     build-depends:     base             >= 4.7  && < 5.0,                        mwc-random       >= 0.13 && < 0.14,                        text             >= 0.11 && < 1.3,-                       pretty           >= 1.1  && < 1.2,-                       hakaru           >= 0.3+                       pretty           >= 1.1  && < 1.2  ---------------------------------------------------------------- Executable disintegrate@@ -309,8 +318,7 @@                        mwc-random           >= 0.13 && < 0.14,                        text                 >= 0.11 && < 1.3,                        pretty               >= 1.1  && < 1.2,-                       optparse-applicative >= 0.11 && < 0.15,-                       hakaru               >= 0.3+                       optparse-applicative >= 0.11 && < 0.15  ---------------------------------------------------------------- Executable pretty@@ -319,12 +327,24 @@     Default-Language:  Haskell2010     GHC-Options:       -O2 -Wall -fwarn-tabs -    build-depends:     base             >= 4.7  && < 5.0,-                       text             >= 0.11 && < 1.3,-                       pretty           >= 1.1  && < 1.2,-                       hakaru           >= 0.3+    build-depends:     base                 >= 4.7  && < 5.0,+                       text                 >= 0.11 && < 1.3,+                       pretty               >= 1.1  && < 1.2,+                       optparse-applicative >= 0.11 && < 0.15  ----------------------------------------------------------------+Executable prettyinternal+    Main-is:           PrettyInternal.hs+    Hs-Source-Dirs:    commands+    Default-Language:  Haskell2010+    GHC-Options:       -O2 -Wall -fwarn-tabs++    build-depends:     base                 >= 4.7  && < 5.0,+                       text                 >= 0.11 && < 1.3,+                       pretty               >= 1.1  && < 1.2,+                       optparse-applicative >= 0.11 && < 0.15++---------------------------------------------------------------- Executable momiji     Main-is:           Momiji.hs     Hs-Source-Dirs:    commands@@ -332,8 +352,7 @@     GHC-Options:       -O2 -Wall -fwarn-tabs      build-depends:     base             >= 4.7  && < 5.0,-                       text             >= 0.11 && < 1.3,-                       hakaru           >= 0.3+                       text             >= 0.11 && < 1.3  ---------------------------------------------------------------- Executable normalize@@ -346,8 +365,7 @@                        mwc-random       >= 0.13 && < 0.14,                        text             >= 0.11 && < 1.3,                        mtl              >= 2.1,-                       pretty           >= 1.1  && < 1.2,-                       hakaru           >= 0.3+                       pretty           >= 1.1  && < 1.2   ----------------------------------------------------------------@@ -364,8 +382,7 @@                        optparse-applicative >= 0.11 && < 0.15,                        pretty               >= 1.1  && < 1.2,                        process              >= 1.1  && < 2.0,-                       semigroups           >= 0.16,-                       hakaru               >= 0.3+                       semigroups           >= 0.16   ----------------------------------------------------------------@@ -379,8 +396,7 @@                        mwc-random       >= 0.13 && < 0.14,                        text             >= 0.11 && < 1.3,                        mtl              >= 2.1,-                       pretty           >= 1.1  && < 1.2,-                       hakaru           >= 0.3+                       pretty           >= 1.1  && < 1.2  ---------------------------------------------------------------- ----------------------------------------------------------- fin.

@@ -1,5 +1,5 @@ -- TODO: merge with the Posta version. And release them as a standalone package-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --                                                    2015.12.17@@ -25,13 +25,19 @@ import Data.Monoid (Monoid(..)) #endif +#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif++import Data.Data (Data, Typeable)+ ---------------------------------------------------------------- ---------------------------------------------------------------- -- | Natural numbers, with fixed-width à la 'Int'. N.B., the 'Num' -- instance will throw errors on subtraction, negation, and -- 'fromInteger' when the result is not a natural number. newtype Nat = Nat Int-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Data, Typeable)  -- TODO: should we define our own Show instance, in order to just -- show the Int itself, relying on our 'fromInteger' definition to@@ -138,10 +144,14 @@ ---------------------------------------------------------------- newtype MaxNat = MaxNat { unMaxNat :: Nat } -instance Monoid MaxNat where-    mempty                        = MaxNat 0-    mappend (MaxNat m) (MaxNat n) = MaxNat (max m n)+instance Semigroup MaxNat where+    MaxNat m <> MaxNat n = MaxNat (max m n) +instance Monoid MaxNat where+    mempty  = MaxNat 0+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif  ---------------------------------------------------------------- _errmsg_unsafeNat, _errmsg_subtraction, _errmsg_negate, _errmsg_fromInteger, _errmsg_succ, _errmsg_pred, _errmsg_toEnum

@@ -28,6 +28,11 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid(..)) #endif++#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup+#endif+ import Data.Ratio  ----------------------------------------------------------------@@ -150,9 +155,14 @@ ---------------------------------------------------------------- newtype MaxNatural = MaxNatural { unMaxNatural :: Natural } +instance Semigroup MaxNatural where+    MaxNatural m <> MaxNatural n = MaxNatural (max m n)+ instance Monoid MaxNatural where-    mempty                                = MaxNatural 0-    mappend (MaxNatural m) (MaxNatural n) = MaxNatural (max m n)+    mempty  = MaxNatural 0+#if !(MIN_VERSION_base(4,11,0))+    mappend = (<>)+#endif   ----------------------------------------------------------------

@@ -3,7 +3,6 @@ module Data.Text.Utf8 where  import           Prelude               hiding (putStr, putStrLn)-import           Control.Applicative   (liftA)  #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative   (Applicative(..), (<$>))@@ -13,7 +12,6 @@ import qualified Data.Text             as Text import           Data.Text.Encoding    (decodeUtf8, encodeUtf8) import           System.IO (Handle)-import           Data.Monoid ((<>))  readFile :: FilePath -> IO Text.Text readFile f = decodeUtf8 <$> (BIO.readFile f)

@@ -8,10 +8,11 @@ -- Stability   :  experimental -- Portability :  GHC-only -----   An AST for the C Family and preprocessor--- Much of this is based on Manuel M T Chakravarty and Benedikt--- Hubar's "language-c" package+--   An AST for the C Family and preprocessor. Much of this was originally based+-- on Manuel M T Chakravarty and Benedikt Hubar's "language-c" package. --+-- It is an AST for the C99 standard and should compile with the -pedantic flag+-- --------------------------------------------------------------------------------  module Language.Hakaru.CodeGen.AST@@ -177,7 +178,7 @@ data CDirectDeclr   = CDDeclrIdent Ident   | CDDeclrArr   CDirectDeclr (Maybe CExpr)-  | CDDeclrFun   CDirectDeclr [CTypeSpec]+  | CDDeclrFun   CDirectDeclr [[CTypeSpec]]   | CDDeclrRec   CDeclr   deriving (Show, Eq, Ord) 

@@ -44,9 +44,9 @@   , extDeclareTypes    , funCG-  , isParallel-  , mkParallel-  , mkSequential+  , whenPar+  , parDo+  , seqDo    , reserveIdent   , genIdent@@ -81,7 +81,6 @@ import Language.Hakaru.Types.Sing import Language.Hakaru.CodeGen.Types import Language.Hakaru.CodeGen.AST-import Language.Hakaru.CodeGen.Pretty import Language.Hakaru.CodeGen.Libs  import Data.Number.Nat (fromNat)@@ -89,23 +88,23 @@ import qualified Data.Text          as T import qualified Data.Set           as S -import Text.PrettyPrint (render)- -- CG after "codegen", holds the state of a codegen computation-data CG = CG { freshNames    :: [String]     -- ^ fresh names for code generations-             , reservedNames :: S.Set String -- ^ reserve names during code generations-             , extDecls      :: [CExtDecl]   -- ^ total external declarations-             , declarations  :: [CDecl]      -- ^ declarations in local block-             , statements    :: [CStat]      -- ^ statements can include assignments as well as other side-effects-             , varEnv        :: Env          -- ^ mapping between Hakaru vars and codegeneration vars-             , managedMem    :: Bool         -- ^ garbage collected block-             , sharedMem     :: Bool         -- ^ shared memory supported block-             , distributed   :: Bool         -- ^ distributed supported block-             , logProbs      :: Bool         -- ^ true by default, but might not matter in some situations-             }+data CG = CG+  { freshNames    :: [String]     -- ^ fresh names for code generations+  , reservedNames :: S.Set String -- ^ reserve names during code generations+  , extDecls      :: [CExtDecl]   -- ^ total external declarations+  , declarations  :: [CDecl]      -- ^ declarations in local block+  , statements    :: [CStat]      -- ^ statements can include assignments as well as other side-effects+  , varEnv        :: Env          -- ^ mapping between Hakaru vars and codegeneration vars+  , managedMem    :: Bool         -- ^ garbage collected block+  , sharedMem     :: Bool         -- ^ shared memory supported block (OpenMP)+  , simd          :: Bool         -- ^ support single instruction multiple data instructions  (OpenMP)+  , distributed   :: Bool         -- ^ distributed supported block+  , logProbs      :: Bool         -- ^ true by default, but might not matter in some situations+  }  emptyCG :: CG-emptyCG = CG cNameStream mempty mempty [] [] emptyEnv False False False True+emptyCG = CG cNameStream mempty mempty [] [] emptyEnv False False False False True  type CodeGen = State CG @@ -132,18 +131,26 @@  -------------------------------------------------------------------------------- -isParallel :: CodeGen Bool-isParallel = sharedMem <$> get+whenPar :: CodeGen () -> CodeGen ()+whenPar m = (sharedMem <$> get) >>= (\b -> when b m) -mkParallel :: CodeGen ()-mkParallel =-  do cg <- get-     put (cg { sharedMem = True } )+parDo :: CodeGen a -> CodeGen a+parDo m = do+  cg <- get+  put (cg { sharedMem = True } )+  a <- m+  cg' <- get+  put (cg' { sharedMem = sharedMem cg } )+  return a -mkSequential :: CodeGen ()-mkSequential =-  do cg <- get-     put (cg { sharedMem = False } )+seqDo :: CodeGen a -> CodeGen a+seqDo m = do+  cg <- get+  put (cg { sharedMem = False } )+  a <- m+  cg' <- get+  put (cg' { sharedMem = sharedMem cg } )+  return a  -------------------------------------------------------------------------------- @@ -267,27 +274,6 @@                                else d:extds                   put $ cg { extDecls = extds' } -funCG :: CTypeSpec -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()-funCG ts ident args m =-  do cg <- get-     let (_,cg') = runState m $ cg { statements   = []-                                   , declarations = []-                                   , freshNames   = cNameStream }-     let decls = reverse . declarations $ cg'-         stmts = reverse . statements   $ cg'-     -- reset local statements and declarations-     put $ cg' { statements   = statements cg-               , declarations = declarations cg-               , freshNames   = freshNames cg }-     extDeclare . CFunDefExt $-       CFunDef [CTypeSpec ts]-               (CDeclr Nothing (CDDeclrIdent ident))-               args-               (CCompound ((fmap CBlockDecl decls) ++ (fmap CBlockStat stmts)))---- --------- -- ENV -- ---------@@ -306,9 +292,35 @@ lookupVar (Variable _ nat _) (Env env) =   IM.lookup (fromNat nat) env -------------------------------------------------------------------- Control Flow+--------------------------------------------------------------------------------+--                      Control Flow and Code Blocks                          --+--------------------------------------------------------------------------------+{-+Monadic operations funCG, ifCG, whileCG, forCG, reductionCG, and codeBlockCG all+generate compound C statements (several declarations and statements surrounded+by '{' '}'). It is important that these code blocks float external functions and+imports to the top of the generated C file AND keep a set of the variable+declarations local to the block of code.+-} +funCG :: [CTypeSpec] -> Ident -> [CDecl] -> CodeGen () -> CodeGen ()+funCG ts ident args m =+  do cg <- get+     let (_,cg') = runState m $ cg { statements   = []+                                   , declarations = []+                                   , freshNames   = cNameStream }+     let decls = reverse . declarations $ cg'+         stmts = reverse . statements   $ cg'+     -- reset local statements and declarations+     put $ cg' { statements   = statements cg+               , declarations = declarations cg+               , freshNames   = freshNames cg }+     extDeclare . CFunDefExt $+       CFunDef (fmap CTypeSpec ts)+               (CDeclr Nothing (CDDeclrIdent ident))+               args+               (CCompound ((fmap CBlockDecl decls) ++ (fmap CBlockStat stmts)))+ ifCG :: CExpr -> CodeGen () -> CodeGen () -> CodeGen () ifCG bE m1 m2 =   do cg <- get@@ -361,9 +373,7 @@      put $ cg' { statements   = statements cg                , declarations = declarations cg                , sharedMem    = sharedMem cg } -- only use pragmas at the top level-     par <- isParallel-     when par . putStat . CPPStat . PPPragma-       $ ["omp","parallel","for"]+     whenPar . putStat . CPPStat . ompToPP $ OMP (Parallel [For])      putStat $ CFor (Just iter)                     (Just cond)                     (Just inc)@@ -371,54 +381,79 @@                                ++ (fmap CBlockStat (reverse $ statements cg'))))  {--The operation for a reduction is either a builtin binary op, or must be-specified+The operation for a reduction is either a builtin binary op (which is a built+in OpenMP reducer),++OR, it must be specified for a given Hakaru type. This will generate fuctions+for the monoidal operations mempty and mappend, use these to generate OpenMP+reduction declarations, and then outfit a for loop with the pragma calling the+reduction. -} reductionCG-  :: Either CBinaryOp (CExpr -> CExpr -> CExpr)-  -> Ident-  -> CExpr-  -> CExpr-  -> CExpr-  -> CodeGen ()+  :: Either CBinaryOp+            ( Sing (a :: Hakaru)             -- type of reduction sections+            , CExpr -> CodeGen ()            -- monoidal unit+            , CExpr -> CExpr -> CodeGen () ) -- monoidal multiplication+  -> CExpr       -- accumulator var+  -> CExpr       -- iteration var+  -> CExpr       -- iteration condition+  -> CExpr       -- iteration increment+  -> CodeGen ()  -- body of the loop   -> CodeGen () reductionCG op acc iter cond inc body =   do cg <- get-     let (_,cg') = runState body $ cg { statements = []+     let (_,cg') = runState body $ cg { statements   = []                                       , declarations = []-                                      , sharedMem = False } -- only use pragmas at the top level+                                      , sharedMem    = False } -- only use pragmas at the top level      put $ cg' { statements   = statements cg                , declarations = declarations cg                , sharedMem    = sharedMem cg }-     par <- isParallel-     when par $+     whenPar $        case op of-         Left binop -> putStat . CPPStat . PPPragma $-                         [ "omp","parallel","for","reduction("-                         , render . pretty $ binop-                         , ":"-                         , render . pretty $ acc-                         ,")"]-         -- INCOMPLETE-         Right red  -> do (Ident redName) <- genIdent' "red"-                          let declRedPragma = [ "omp","declare","reduction("-                                              , redName,":",undefined,":"-                                              , render . pretty $-                                                  red (CVar . Ident $ "omp_in")-                                                      (CVar . Ident $ "omp_out")-                                              , ")"]-                              redPragma = [ "omp","parallel","for","reduction("-                                          , redName-                                          , ":"-                                          , render . pretty $ acc-                                          ,")"]-                          putStat . CPPStat . PPPragma $ declRedPragma-                          putStat . CPPStat . PPPragma $ redPragma+         Left binop ->+           putStat . CPPStat . ompToPP $+             OMP (Parallel [For,Reduction (Left binop) [acc]])+         Right (typ,unit,mul) ->+           do { redId <- declareReductionCG typ unit mul+              ; putStat . CPPStat . ompToPP $+                  OMP (Parallel [For,Reduction (Right redId) [acc]]) }      putStat $ CFor (Just iter)                     (Just cond)                     (Just inc)                     (CCompound $  (fmap CBlockDecl (reverse $ declarations cg')                                ++ (fmap CBlockStat (reverse $ statements cg'))))++-- given a monoid for a Hakaru type, generate the appropriate openMP reduction+-- declaration and return its unique identifier+declareReductionCG+  :: Sing (a :: Hakaru)+  -> (CExpr -> CodeGen ())+  -> (CExpr -> CExpr -> CodeGen ())+  -> CodeGen Ident+declareReductionCG typ unit mul =+  do (redId:unitId:mulId:[]) <- mapM genIdent' ["red","unit","mul"]+     let declType = typePtrDeclaration typ++     inId <- genIdent' "in"+     funCG [CVoid] unitId [declType inId] $+       unit . CVar $ inId++     (outId:in2Id:[]) <- mapM genIdent' ["out","in"]+     funCG [CVoid] mulId [declType outId,declType in2Id] $+       mul (CVar outId) (CVar in2Id)++     let typ' = case buildType typ of+                  (x:_) -> x+                  _ -> error $ "buildType{" ++ (show typ) ++ "}"+     putStat . CPPStat . ompToPP $+       OMP (DeclareRed redId+                       typ'+                       (CCall (CVar mulId)+                              (fmap (address . CVar . Ident)+                                    ["omp_in","omp_out"]))+                       (CCall (CVar unitId)+                              [address . CVar . Ident $ "omp_priv"]))+     return redId   -- not control flow, but like these it creates a block with local variables

@@ -45,18 +45,15 @@ import Language.Hakaru.Syntax.TypeOf import Language.Hakaru.Syntax.Datum hiding (Ident) import Language.Hakaru.Syntax.Reducer+import Language.Hakaru.Syntax.IClasses import qualified Language.Hakaru.Syntax.Prelude as HKP import Language.Hakaru.Types.DataKind import Language.Hakaru.Types.HClasses-import Language.Hakaru.Syntax.IClasses import Language.Hakaru.Types.Coercion import Language.Hakaru.Types.Sing  import           Control.Monad.State.Strict-import           Control.Monad (replicateM)-import           Control.Applicative (pure) import           Data.Number.Natural-import           Data.Monoid        hiding (Product,Sum) import           Data.Ratio import qualified Data.List.NonEmpty as NE import qualified Data.Sequence      as S@@ -65,7 +62,10 @@   #if __GLASGOW_HASKELL__ < 710+import           Control.Applicative (pure)+import           Control.Monad (replicateM) import           Data.Functor+import           Data.Monoid        hiding (Product,Sum) #endif  @@ -171,27 +171,48 @@     \loc -> do       caseBind body $ \v@(Variable _ _ typ) body'->         do ident <- createIdent v-           case typ of-             (SFun _ _) -> return ()-             _ -> declare typ ident+           declare typ ident            flattenABT expr (CVar ident)            flattenABT body' loc  -- Lambdas produce functions and then return a function label exprssion flattenSCon Lam_ =   \(body :* End) ->-    \loc -> do-      -- externally declare closure and function-      closureTypeSpec <- coalesceLambda body extDeclClosure--      -- declare local closure var-      closureId <- genIdent' "closure"-      declare' (buildDeclaration closureTypeSpec closureId)+    \loc ->+      coalesceLambda body $ \args body' ->+        let freevars = fromVarSet . freeVars $ body'+            retTyp   = typeOf body'+        in do { -- create code block and closure structure+                args' <- sequence . foldMap11 argDecl $ args+              ; envId <- genIdent' "env"+              ; fnId  <- genIdent' "fn"+              ; closDataId@(Ident clos_n) <- genIdent' "clos_data"+              ; extDeclare (closureStructure freevars args closDataId retTyp)+              ; funCG (buildType retTyp)+                      fnId+                      ((buildDeclaration (callStruct clos_n) envId):args') $+                  do { putStat (opComment "Begin Unpack Closure")+                       -- need to re-declare variables in functions scope+                     ; mapM_ (\(SomeVariable v@(Variable _ _ typ)) ->+                               lookupIdent v >>= declare typ)+                             freevars+                     ; unpackClosure (CVar envId) cNameStream freevars+                     ; putStat (opComment "End Unpack Closure")+                     ; x <- flattenWithName body'+                     ; putStat . CReturn . Just $ x } -      -- capture environment in closure-      putExprStat $ loc .=. (CVar closureId)+                -- create the closure object+              ; closureId <- genIdent' "closure"+              ; declare' . buildDeclaration (callStruct clos_n) $ closureId+              ; putStat (opComment "Begin Pack Closure")+              ; putExprStat $ ((CVar closureId) ... "_code_ptr") .=. (address (CVar fnId))+              ; packClosure (CVar closureId) cNameStream freevars+              ; putStat (opComment "End Pack Closure")+              ; putExprStat $ loc .=. (CVar closureId) } -  where coalesceLambda+  where -- collapses nested lambdas of one argument to lambdas that take a list+        -- arguments+        coalesceLambda           :: ( ABT Term abt )           => abt '[x] a           -> (forall (ys :: [Hakaru]) b. List1 Variable ys -> abt '[] b -> r)@@ -204,65 +225,37 @@                   coalesceLambda body $ \vars abt'' -> k (Cons1 v vars) abt''                 _ -> k (Cons1 v Nil1) abt' -        -- given a parameter, create identifiers corresponding to Hakaru vars,-        -- and return a CTypeSpec for the param-        -- Will this fail if the parameter is a SFun?-        mkVarIdandSpec :: Variable (a :: Hakaru) -> CodeGen (Ident,[CTypeSpec])-        mkVarIdandSpec v@(Variable _ _ typ) = do-          extDeclareTypes typ-          vId <- createIdent v-          return (vId,buildType typ)+        argDecl :: Variable (a :: Hakaru) -> [CodeGen CDecl]+        argDecl v@(Variable _ _ typ) =+          [do { ident <- createIdent v ; return (typeDeclaration typ ident) }] -        extDeclClosure-          :: ( ABT Term abt )-          => List1 Variable (ys :: [Hakaru])-          -> abt '[] b-          -> CodeGen CTypeSpec-        extDeclClosure vars body'= do-          funcId <- genIdent' "fn"-          idAndSpecs <- sequence $ foldMap11 (\v -> [mkVarIdandSpec v]) vars-          let fVars   = freeVars body'-              typ     = typeOf body'-          sId@(Ident sname) <- extDeclClosureStruct typ (fmap snd idAndSpecs) fVars-          funCG (head . buildType $ typ)-                funcId-                ([buildDeclaration (callStruct sname) (Ident "env")]-                 ++ (fmap (\(vId,specs) -> buildDeclaration' specs vId) idAndSpecs))-                ((putStat . CReturn . Just) =<< flattenWithName body')-          return (callStruct sname)+        -- captures the environment variables in closure object+        packClosure, unpackClosure+          :: CExpr+          -> [String]+          -> [SomeVariable (KindOf (a :: Hakaru))]+          -> CodeGen ()+        packClosure _ _      [] = return ()+        packClosure c (n:ns) ((SomeVariable a):as) =+          do { a' <- CVar <$> lookupIdent a+             ; putExprStat $ c ... n .=. a'+             ; packClosure c ns as }+        packClosure _ _ _ = error "this isn't possible" -        extDeclClosureStruct-          :: forall (a :: Hakaru) (ys :: [Hakaru])-          .  Sing a-          -> [[CTypeSpec]]-          -> VarSet (KindOf a)-          -> CodeGen Ident-        extDeclClosureStruct retTyp paramTypeSpecs freeVars = do-          sId@(Ident sname) <- genIdent' "clos"-          freeVarDecls <- mapM (\(SomeVariable v@(Variable _ _ typ)) -> do-                                  extDeclareTypes typ-                                  vId <- createIdent v-                                  return (typeDeclaration typ vId)-                               ) (fromVarSet freeVars)-          let funPtrDecl =-                CDecl (fmap CTypeSpec $ buildType retTyp)-                      [( CDeclr Nothing-                         (CDDeclrFun-                           (CDDeclrRec (CDeclr (Just $ CPtrDeclr []) (CDDeclrIdent . Ident $ "fn")))-                           ([callStruct sname]++(concat paramTypeSpecs)))-                       , Nothing)]-          extDeclare $ CDeclExt-                     $ CDecl [ CTypeSpec $ buildStruct (Just sId)-                                             ([funPtrDecl]++freeVarDecls) ]-                             []-          return sId+        unpackClosure _ _      [] = return ()+        unpackClosure c (n:ns) ((SomeVariable a):as) =+          do { a' <- CVar <$> lookupIdent a+             ; putExprStat $ a' .=. c ... n+             ; unpackClosure c ns as }+        unpackClosure _ _ _ = error "this isn't possible"  flattenSCon App_  =  \(fun :* arg :* End) ->-   \loc -> do-     closE <- flattenWithName' fun "clos"-     paramE <- flattenWithName' fun "param"-     putExprStat $ loc .=. (CCall (CMember closE (Ident "fn") True) [paramE])+   \loc ->+     do { closE <- flattenWithName' fun "closure"+        ; paramE <- flattenWithName' arg "param"+        ; putExprStat $ loc .=. CCall (indirect (closE ... "_code_ptr"))+                                      [closE,paramE] }  flattenSCon (PrimOp_ op) = flattenPrimOp op @@ -306,7 +299,7 @@                      iterVar = CVar iterI                   reductionCG (Left CAddOp)-                             accI+                             accVar                              (iterVar .=. loE)                              (iterVar .<. hiE)                              (CUnary CPostIncOp iterVar) $@@ -345,7 +338,7 @@                      iterVar = CVar iterI                   reductionCG (Left CMulOp)-                             accI+                             accVar                              (iterVar .=. loE)                              (iterVar .<. hiE)                              (CUnary CPostIncOp iterVar) $@@ -404,7 +397,7 @@ flattenSCon Plate           =   \(size :* b :* End) ->     \loc ->-      caseBind b $ \v@(Variable _ _ typ) body ->+      caseBind b $ \v body ->         do sizeE <- flattenWithName' size "s"            isMM <- managedMem <$> get            when (not isMM) (error "plate will leak memory without the '-g' flag and boehm-gc")@@ -426,7 +419,7 @@            let sampE = CVar sampId             reductionCG (Left CAddOp)-                       weightId+                       weightE                        (itE .=. (intE 0))                        (itE .<. sizeE)                        (CUnary CPostIncOp itE)@@ -557,9 +550,9 @@           => abt '[] a           -> Integer           -> (CExpr -> CodeGen ())-        assignIndex e index loc = do+        assignIndex e i loc = do           eE <- flattenWithName e-          putExprStat $ indirect ((arrayData loc) .+. (intE index)) .=. eE+          putExprStat $ indirect ((arrayData loc) .+. (intE i)) .=. eE  -------------- -- ArrayOps --@@ -647,11 +640,21 @@     declare SNat itId     let itE = CVar itId     initRed red loc-    forCG (itE .=. loE)-          (itE .<. hiE)-          (CUnary CPostIncOp itE)-          (accumRed red itE loc)+    isPar <- sharedMem <$> get+    -- declare special functions for combining threads. This doesn't completely+    -- work now, because these need to capture free variables.+    reductionCG (Right ( typeOfReducer red+                       , \e -> seqDo (  initRed red (indirect e)+                                     >> putStat (CReturn Nothing))+                       , \a b -> seqDo (  mulRed red (indirect a) (indirect b)+                                       >> putStat (CReturn Nothing))))+                loc+                (itE .=. loE)+                (itE .<. hiE)+                (CUnary CPostIncOp itE)+                (accumRed isPar red itE loc)     putStat $ opComment "End Bucket"+   where initRed           :: (ABT Term abt)           => Reducer abt xs a@@ -670,7 +673,7 @@                        (Variable _ _ typ') ->                          [declare typ' =<< createIdent v'])                      $ vs-                   sE <- flattenWithName s'+                   sE <- flattenWithName' s' "red_size"                    putExprStat $ arraySize loc .=. sE                    putMallocStat (arrayData loc) sE btyp                    itId  <- genIdent@@ -686,10 +689,11 @@          accumRed           :: (ABT Term abt)-          => Reducer abt xs a+          => Bool+          -> Reducer abt xs a           -> CExpr           -> (CExpr -> CodeGen ())-        accumRed mr itE = \loc ->+        accumRed isPar mr itE = \loc ->           case mr of             (Red_Index _ a body) ->               caseBind a $ \v@(Variable _ _ typ) a' ->@@ -703,9 +707,9 @@                            [declare typ' =<< createIdent v'])                        $ vs                      aE <- flattenWithName' a'' "index"-                     accumRed body itE (index (arrayData loc) aE)-            (Red_Fanout mr1 mr2) -> accumRed mr1 itE (datumFst loc)-                                 >> accumRed mr2 itE (datumSnd loc)+                     accumRed isPar body itE (index (arrayData loc) aE)+            (Red_Fanout mr1 mr2) -> accumRed isPar mr1 itE (datumFst loc)+                                 >> accumRed isPar mr2 itE (datumSnd loc)             (Red_Split b mr1 mr2) ->               caseBind b $ \v@(Variable _ _ typ) b' ->                 let (vs,b'') = caseBinds b' in@@ -719,8 +723,8 @@                        $ vs                      bE <- flattenWithName' b'' "cond"                      ifCG (bE ... "index" .==. (intE 0))-                          (accumRed mr1 itE (datumFst loc))-                          (accumRed mr2 itE (datumSnd loc))+                          (accumRed isPar mr1 itE (datumFst loc))+                          (accumRed isPar mr2 itE (datumSnd loc))             Red_Nop -> return ()             (Red_Add sr e) ->               caseBind e $ \v@(Variable _ _ typ) e' ->@@ -734,10 +738,32 @@                            [declare typ' =<< createIdent v'])                        $ vs                      eE <- flattenWithName e''+                     -- when isPar $  putStat . CPPStat . ompToPP $ OMP Critical                      case sing_HSemiring sr of                        SProb -> logSumExpCG (S.fromList [loc,eE]) loc                        _ -> putExprStat $ loc .+=. eE +        mulRed+          :: (ABT Term abt)+          => Reducer abt xs a+          -> (CExpr -> CExpr -> CodeGen ())+        mulRed mr outp inp =+          case mr of+             (Red_Index _ _ mr') ->+               do itE <- localVar SNat+                  forCG (itE .=. (intE 0))+                        (itE .<. (intE 0))+                        (CUnary CPostIncOp itE)+                        (mulRed mr'+                                (index (arrayData outp) itE)+                                (index (arrayData inp) itE))+             (Red_Fanout mr1 mr2) -> mulRed mr1 (datumFst outp) (datumFst inp)+                                  >> mulRed mr2 (datumFst outp) (datumFst inp)+             (Red_Split _ mr1 mr2) -> mulRed mr1 (datumFst outp) (datumFst inp)+                                   >> mulRed mr2 (datumFst outp) (datumFst inp)+             Red_Nop -> return ()+             (Red_Add _ _) -> putExprStat $ outp .+=. inp+ addMonoidIdentity :: Sing (a :: Hakaru) -> CExpr addMonoidIdentity s =   case s of@@ -775,9 +801,9 @@   -> CExpr   -> CodeGen () assignDatum code ident =-  let index     = getIndex code-      indexExpr = CMember ident (Ident "index") True-  in  do putExprStat (indexExpr .=. (intE index))+  let ind       = getIndex code+      indExpr = CMember ident (Ident "index") True+  in  do putExprStat (indExpr .=. (intE ind))          sequence_ $ assignSum code ident   where getIndex :: DatumCode xss b c -> Integer         getIndex (Inl _)    = 0@@ -831,6 +857,7 @@                             True      rest' <- assignProd' rest topIdent (CVar sumIdent)      return $ [flattenABT d varName] ++ rest'+ assignProd' _ _ _  = error $ "TODO: assignProd Ident"  @@ -897,8 +924,7 @@       do aE <- flattenWithName a          bId <- genIdent          declare (typeOf a) bId-         let datumIndex e = CMember e (Ident "index") True-             bE = CVar bId+         let bE = CVar bId          putExprStat $ datumIndex bE .=. (CCond (datumIndex aE .==. (intE 1))                                                (intE 0)                                                (intE 1))@@ -990,6 +1016,8 @@      do aE <- flattenWithName a         putExprStat $ loc .=. (CUnary CMinOp $ aE) +flattenPrimOp Choose = \(_ :* _ :* End) -> error $ "TODO: flattenPrimOp: choose"+ flattenPrimOp t  = \_ -> error $ "TODO: flattenPrimOp: " ++ show t  @@ -1235,40 +1263,36 @@         let currE = index (arrayData arrE) itE -       isPar <- isParallel-       mkSequential--       -- Calculate the maximum value of the input array-       -- And calculate the total weight-       forCG (itE .=. (intE 0))-             (itE .<. (arraySize arrE))-             (CUnary CPostIncOp itE) $ do-         ifCG (wMaxE .<. currE)-              (putExprStat $ wMaxE .=. currE)-              (return ())-         logSumExpCG (S.fromList [wSumE, currE]) wSumE-       putExprStat $ wSumE .=. (wSumE .-. wMaxE)--       -- draw number from uniform(0, weightSum)-       rId <- genIdent' "r"-       declare SReal rId-       let r    = castTo [CDouble] randE-           rMax = castTo [CDouble] (CVar . Ident $ "RAND_MAX")-           rE = CVar rId-       assign rId (logE (r ./. rMax) .+. wSumE)+       seqDo $ do+         -- Calculate the maximum value of the input array+         -- And calculate the total weight+         forCG (itE .=. (intE 0))+               (itE .<. (arraySize arrE))+               (CUnary CPostIncOp itE) $ do+           ifCG (wMaxE .<. currE)+                (putExprStat $ wMaxE .=. currE)+                (return ())+           logSumExpCG (S.fromList [wSumE, currE]) wSumE+         putExprStat $ wSumE .=. (wSumE .-. wMaxE) -       assign wSumId (logE (intE 0))-       assign itId (intE 0)-       whileCG (intE 1) $-         do ifCG (rE .<. wSumE)-                 (do putExprStat $ mdataWeight loc .=. (intE 0)-                     putExprStat $ mdataSample loc .=. (itE .-. (intE 1))-                     putStat CBreak)-                 (return ())-            logSumExpCG (S.fromList [wSumE, currE .-. wMaxE]) wSumE-            putExprStat $ CUnary CPostIncOp itE+         -- draw number from uniform(0, weightSum)+         rId <- genIdent' "r"+         declare SReal rId+         let r    = castTo [CDouble] randE+             rMax = castTo [CDouble] (CVar . Ident $ "RAND_MAX")+             rE = CVar rId+         assign rId (logE (r ./. rMax) .+. wSumE) -       when isPar mkParallel+         assign wSumId (logE (intE 0))+         assign itId (intE 0)+         whileCG (intE 1) $+           do ifCG (rE .<. wSumE)+                   (do putExprStat $ mdataWeight loc .=. (intE 0)+                       putExprStat $ mdataSample loc .=. (itE .-. (intE 1))+                       putStat CBreak)+                   (return ())+              logSumExpCG (S.fromList [wSumE, currE .-. wMaxE]) wSumE+              putExprStat $ CUnary CPostIncOp itE   flattenMeasureOp x = error $ "TODO: flattenMeasureOp: " ++ show x@@ -1395,7 +1419,7 @@        let argIds = fmap Ident (take size cNameStream)            decls  = fmap (typeDeclaration SProb) argIds            vars   = fmap CVar argIds-       funCG CDouble funcId decls+       funCG [CDouble] funcId decls          (putStat . CReturn . Just . logSumExp . S.fromList $ vars)        putExprStat $ loc .=. (CCall (CVar funcId) (F.toList seqE)) @@ -1403,10 +1427,8 @@ -- LogSumExp for Summation of Prob -- ------------------------------------- {-- For summation of SProb we need a new logSumExp function that will find the max of an array and then sum it in a loop- -}  lseSummateArrayCG@@ -1416,7 +1438,7 @@   -> (CExpr -> CodeGen ()) lseSummateArrayCG body arrayE =   caseBind body $ \v body' ->-    \loc -> do+    \loc -> seqDo $ do       (maxVId:maxIId:sumId:[]) <- mapM genIdent' ["maxV","maxI","sum"]       itId <- createIdent v       mapM_ (declare SProb) [maxVId,sumId]@@ -1439,9 +1461,9 @@       forCG (itE .=. intE 0)             (itE .<. arraySize arrayE)             (CUnary CPostIncOp itE)-            (putStat $ CIf (itE .!=. maxIE)-                           (CExpr . Just $ sumE .+=. (expE ((derefIndex itE) .-. (maxVE))))-                           Nothing)+            (ifCG (itE .!=. maxIE)+                  (putExprStat $ sumE .+=. (expE ((derefIndex itE) .-. (maxVE))))+                  (return ()))        putExprStat $ loc .=. (maxVE .+. (log1pE sumE)) @@ -1477,35 +1499,16 @@                 flattenABT body' xE                 putExprStat $ yE .=. (xE .-. cE)                 putExprStat $ zE .=. (tE .+. yE)-                putExprStat $ cE .=.  ((zE .-. tE) .-. yE)-                putExprStat $ tE .=. zE)+                whenPar $ putStat . CPPStat . ompToPP $ OMP Critical+                codeBlockCG $ do+                  putExprStat $ cE .=.  ((zE .-. tE) .-. yE)+                  putExprStat $ tE .=. zE)       putExprStat $ loc .=. tE  -------------------------------------------------------------------------------- --                            Coercion Helpers                                -- -------------------------------------------------------------------------------- --- instance PrimCoerce Value where---     primCoerceTo c l =---         case (c,l) of---         (Signed HRing_Int,            VNat  a) -> VInt  $ fromNat a---         (Signed HRing_Real,           VProb a) -> VReal $ LF.fromLogFloat a---         (Continuous HContinuous_Prob, VNat  a) ->---             VProb $ LF.logFloat (fromIntegral (fromNat a) :: Double)---         (Continuous HContinuous_Real, VInt  a) -> VReal $ fromIntegral a---         _ -> error "no a defined primitive coercion"----     primCoerceFrom c l =---         case (c,l) of---         (Signed HRing_Int,            VInt  a) -> VNat  $ unsafeNat a---         (Signed HRing_Real,           VReal a) -> VProb $ LF.logFloat a---         (Continuous HContinuous_Prob, VProb a) ->---             VNat $ unsafeNat $ floor (LF.fromLogFloat a :: Double)---         (Continuous HContinuous_Real, VReal a) -> VInt  $ floor a---         _ -> error "no a defined primitive coercion"--- coerceToCG   :: forall (a :: Hakaru) (b :: Hakaru)   .  Coercion a b@@ -1562,3 +1565,27 @@           (putExprStat $ x' .=. (logE x))      return x' real2int x =  return (castTo [CInt] x)++--------------------------------------------------------------------------------+--                            Parallel Helpers                                --+--------------------------------------------------------------------------------+{- SIMD (single instruction multiple data) OpenMP pragmas, should be applied to+-- the inner most loop. `hasParallelTerm` checks whether a term or any of its+-- subterms contain a parallel construct { plate, summate, product, array,+-- bucket }.+-}++hasParallelTerm :: ( ABT Term abt ) => abt '[] a -> Bool+hasParallelTerm abt = caseVarSyn abt (const False) hPT'+  where hPT' :: ABT Term abt => Term abt a -> Bool+        hPT' (_ :$ _)          = undefined+        hPT' (NaryOp_ _ _)     = undefined+        hPT' (Literal_ _)      = False+        hPT' (Empty_ _)        = False+        hPT' (Array_ _ _)      = True+        hPT' (ArrayLiteral_ _) = False+        hPT' (Bucket _ _ _)    = True+        hPT' (Datum_ _)        = False+        hPT' (Case_ _ _)       = undefined+        hPT' (Superpose_ _)    = undefined+        hPT' (Reject_ _)       = False

@@ -27,10 +27,13 @@     gcHeader, gcInit, gcMalloc,      -- OpenMP-    openMpHeader, ompGetNumThreads, ompGetThreadNum,+    openMpHeader, ompGetNumThreads, ompGetThreadNum, OMP(..), Directive(..),+    ompToPP   ) where  import Language.Hakaru.CodeGen.AST+import Language.Hakaru.CodeGen.Pretty+import Text.PrettyPrint (render)  {- @@ -129,6 +132,8 @@    For generating pragmas for shared memory parallelism, that is parallelism on    on a single process that makes use of multithreaded processors. This    interface is implemented in most C compilers and is accessed through pragmas++   This is a subset of the the OpenMP 4.5 standard. -}  openMpHeader :: Preprocessor@@ -139,3 +144,30 @@  ompGetThreadNum :: CExpr ompGetThreadNum = mkCallE "omp_get_thread_num" []++data OMP = OMP Directive++data Directive+  = Parallel [Directive]+  | For+  | Critical+  | Reduction (Either CBinaryOp Ident) [CExpr]+  | DeclareRed Ident CTypeSpec CExpr CExpr++ompToPP :: OMP -> Preprocessor+ompToPP (OMP d) = PPPragma $ "omp":(showDirective d)+  where showDirective :: Directive -> [String]+        showDirective (Parallel ds)      = "parallel":(concatMap showDirective ds)+        showDirective For                = ["for"]+        showDirective Critical           = ["critical"]+        showDirective (Reduction eop vs) =+          let op = case eop of+                     Left binop -> render . pretty $ binop+                     Right (Ident s) -> s+          in  ["reduction(",op,":",unwords . fmap (render. pretty) $ vs,")"]+        showDirective (DeclareRed (Ident name) typ mul unit) =+          let typ'  = render . pretty $ typ+              mul'  = render . pretty $ mul+              unit' = render . pretty $ unit+          in ["declare","reduction(",name,":",typ',":",mul',") initializer ("+             ,unit',")"]

@@ -18,6 +18,7 @@   , Pretty   ) where +import Prelude hiding ((<>)) import Text.PrettyPrint import Language.Hakaru.CodeGen.AST @@ -43,8 +44,8 @@ parensPrec :: Int -> Int -> Doc -> Doc parensPrec x y = if x <= y then parens else id -newline :: Doc-newline = char '\n'+emptyText :: Doc+emptyText = text ""  instance Pretty a => Pretty (Maybe a) where   pretty Nothing  = empty@@ -59,11 +60,11 @@   pretty (Ident i) = text i  instance Pretty CAST where-  pretty (CAST extdecls) = (vcat . fmap pretty $ extdecls) $$ newline+  pretty (CAST extdecls) = vcat . fmap pretty $ extdecls  instance Pretty CExtDecl where-  pretty (CDeclExt d) =  newline <> pretty d <> semi-  pretty (CFunDefExt f) = newline <> pretty f+  pretty (CDeclExt d) = emptyText $+$ pretty d <> semi+  pretty (CFunDefExt f) = emptyText $+$ pretty f   pretty (CCommentExt s) = text "/*" <+> text s <+> text "*/"   pretty (CPPExt p) = pretty p @@ -72,7 +73,7 @@     ((hsep . fmap pretty $ dspecs)      <+> pretty dr      <>  (parens . hsep . punctuate comma . fmap pretty $ ds))-    $+$ pretty s+    $+$ (pretty s)  -------------------------------------------------------------------------------- --                               Preprocessor                                 --@@ -114,7 +115,7 @@   pretty (CDDeclrIdent i) = pretty i   pretty (CDDeclrArr dd e) = pretty dd <+> (brackets . pretty $ e)   pretty (CDDeclrFun dd ts) =-    pretty dd <> (parens . hsep . punctuate comma . fmap pretty $ ts)+    pretty dd <> (parens . hsep . punctuate comma . fmap (hsep . fmap pretty) $ ts)   pretty (CDDeclrRec declr) = parens . pretty $ declr  @@ -160,9 +161,10 @@   pretty (CSUSpec tag mi []) =     pretty tag <+> mpretty mi   pretty (CSUSpec tag mi ds) =-    (pretty tag <+> mpretty mi <+> lbrace)-    $+$ (nest (-1) $ (nest 2 . sep . fmap (\d -> pretty d <> semi)  $ ds)-                     $+$ rbrace)+    (pretty tag <+> pretty mi)+    $+$ (   lbrace+        $+$ (nest 2 . sep . fmap (\d -> pretty d <> semi) $ ds)+        $+$ rbrace )  instance Pretty CSUTag where   pretty CStructTag = text "struct"@@ -192,25 +194,25 @@   pretty (CDefault s) = text "default" <> colon $$ nest 2 (pretty s)   pretty (CExpr me) = mpretty me <> semi   pretty (CCompound bs) =-    nest (-1) (lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace)+    lbrace $+$ (nest 2 . vcat . fmap pretty $ bs) $+$ rbrace -  pretty (CIf ce thns (Just elss)) = nest 1 $+  pretty (CIf ce thns (Just elss)) =     text "if" <+> (parens . prettyPrec (-5) $ ce)-              $+$ (nest 1 $ pretty thns)+              $+$ (pretty thns)               $+$ text "else"-              $+$ (nest 1 $ pretty elss)+              $+$ (pretty elss)   pretty (CIf ce thns Nothing) =-    text "if" <+> (parens . prettyPrec (-5) $ ce) $+$ (nest 1 $ pretty thns)+    text "if" <+> (parens . prettyPrec (-5) $ ce) $+$ (pretty thns)    pretty (CWhile ce s b) =     if b-    then text "do" <+> pretty s <+> text "while" <+> (parens $ pretty ce) <> semi-    else text "while" <+> (parens $ pretty ce) $$ (nest 1 $ pretty s)+    then text "do" $+$ pretty s $+$ (text "while" <+> (parens $ pretty ce) <> semi)+    else (text "while" <+> (parens $ pretty ce)) $+$ (pretty s)    pretty (CFor me mce mie s) =     text "for"     <+> (parens . hsep . punctuate semi . fmap (mPrettyPrec 10) $ [me,mce,mie])-    $$  (nest 1 $ pretty s)+    $$  (pretty s)    pretty CCont = text "continue" <> semi   pretty CBreak = text "break" <> semi

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds,              FlexibleContexts,              GADTs,+             RankNTypes,              KindSignatures #-}  ----------------------------------------------------------------@@ -52,10 +53,11 @@   , datumProd   , datumFst   , datumSnd+  , datumIndex    -- functions and closures   , functionDef-  , closureDeclaration+  , closureStructure    , buildType   , castTo@@ -68,7 +70,9 @@  import Control.Monad.State +import Language.Hakaru.Syntax.ABT import Language.Hakaru.Syntax.AST+import Language.Hakaru.Syntax.IClasses import Language.Hakaru.Types.DataKind import Language.Hakaru.Types.HClasses import Language.Hakaru.Types.Sing@@ -262,10 +266,10 @@ datumSum dat funs ident =   let declrs = fst $ runState (datumSum' dat funs) cNameStream       union  = buildDeclaration (buildUnion declrs) (Ident "sum")-      index  = buildDeclaration CInt (Ident "index")+      ind    = buildDeclaration CInt (Ident "index")       struct = buildStruct (Just ident) $ case declrs of-                                            [] -> [index]-                                            _  -> [index,union]+                                            [] -> [ind]+                                            _  -> [ind,union]   in CDecl [ CTypeSpec struct ] []  datumSum'@@ -326,6 +330,9 @@ datumSnd :: CExpr -> CExpr datumSnd x = x ... "sum" ... "a" ... "b" +datumIndex :: CExpr -> CExpr+datumIndex x = x ... "index"+ -------------------------------------------------------------------------------- --                                Functions                                   -- --------------------------------------------------------------------------------@@ -353,11 +360,32 @@ -- Closures -- -------------- -closureDeclaration-  :: (Sing (a :: Hakaru))-  -> Ident-  -> CDecl-closureDeclaration = buildDeclaration . callStruct . typeName+-- externally declare closure structure+closureStructure+  :: forall (a :: Hakaru) xs+  .  [SomeVariable (KindOf a)]       -- ^ free variables+  -> List1 Variable (xs :: [Hakaru]) -- ^ function arguments+  -> Ident                           -- ^ identifier of function+  -> Sing a                          -- ^ function return type+  -> CExtDecl+closureStructure fvs as i@(Ident name) typ = CDeclExt $+  (CDecl [CTypeSpec $ (buildStruct (Just i) (codePtr:(declFvs cNameStream fvs)))]+         [])+  where declFvs _ [] = []+        declFvs (n:ns) ((SomeVariable (Variable _ _ typ')):as') =+          typeDeclaration typ' (Ident n) : declFvs ns as'+        declFvc [] (_:_) = error "Ran out of identifiers but still had some types to assign"+        codePtr = CDecl (fmap CTypeSpec . buildType $ typ)+                        [(CDeclr Nothing+                           (CDDeclrFun+                             (CDDeclrRec+                               (CDeclr (Just . CPtrDeclr $ [])+                                       (CDDeclrIdent . Ident $ "_code_ptr")))+                             ([callStruct name]:(varTypes as)))+                         ,Nothing)]++        varTypes :: List1 Variable (xs :: [Hakaru]) -> [[CTypeSpec]]+        varTypes = foldMap11 (\(Variable _ _ typ') -> [buildType typ'])   

@@ -72,7 +72,7 @@        ( TypedAST typ' abt,       Just name ) ->          -- still buggy for measures          do mfId <- reserveIdent name-            funCG (head . buildType $ typ') mfId [] $+            funCG (buildType typ') mfId [] $               do outE <- flattenWithName' abt "out"                  putStat . CReturn . Just $ outE @@ -107,7 +107,6 @@ -- when measure, compile to a sampler mainFunction pconfig typ@(SMeasure _) abt =   do mfId    <- reserveIdent "measure"-     mdataId <- reserveIdent "mdata"      mainId  <- reserveIdent "main"      argVId <- reserveIdent "argv"      argCId <- reserveIdent "argc"@@ -115,10 +114,10 @@      extDeclareTypes typ       -- defined a measure function that returns mdata-     funCG (head . buildType $ typ) mfId  [] $+     funCG (buildType typ) mfId  [] $        (putStat . CReturn . Just) =<< flattenWithName' abt "samp" -     funCG CInt mainId mainArgs $+     funCG [CInt] mainId mainArgs $        do isManagedMem <- managedMem <$> get           when isManagedMem (putExprStat gcInit) @@ -131,8 +130,8 @@           printCG pconfig typ (CCall (CVar mfId) []) (Just nSamples)           putStat . CReturn . Just $ intE 0 -mainFunction pconfig typ@(SFun _ _) abt =-  coalesceLambda abt $ \vars abt' ->+mainFunction pconfig (SFun _ _) abt =+  coalesceLambda abt $ \_ abt' ->     do resId  <- reserveIdent "result"        mainId <- reserveIdent "main"        argVId <- reserveIdent "argv"@@ -142,7 +141,7 @@        let (resE:funE:argCE:argVE:[]) = fmap CVar [resId,funId,argCId,argVId]            typ' = typeOf abt' -       funCG CInt mainId mainArgs $+       funCG [CInt] mainId mainArgs $          do isManagedMem <- managedMem <$> get             when isManagedMem (putExprStat gcInit)             declare typ' resId@@ -166,7 +165,7 @@             putStat $ opComment "Parse Args"             argEs <- foldLambdaWithIndex 1 abt $ \i (Variable _ _ t) ->                        do argE <- localVar' t "arg"-                          parseCG t (index argVE (intE i)) argE+                          _ <- parseCG t (index argVE (intE i)) argE                           return argE              case typ' of@@ -185,9 +184,7 @@           :: ABT Term abt           => Integer           -> abt '[] a-          -> ( forall (x :: Hakaru)-             .  Integer-             -> CodeGen ())+          -> (Integer -> CodeGen ())           -> CodeGen ()         withLambdaDepth' n abt_ k =           caseVarSyn abt_@@ -210,7 +207,7 @@      mainId <- reserveIdent "main"      let resE  = CVar resId -     funCG CInt mainId [] $+     funCG [CInt] mainId [] $        do declare typ resId            isManagedMem <- managedMem <$> get@@ -358,16 +355,25 @@ printCG pconfig (SArray typ) arg Nothing =   do itE <- localVar' SNat "it"      putString "[ "-     mkSequential-     forCG (itE .=. (intE 0))-           (itE .<. (arraySize arg))-           (CUnary CPostIncOp itE)-           (putExprStat-           $ printfE [ stringE $ printFormat pconfig typ " "-                     , index (arrayData arg) itE ])+     seqDo $+       forCG (itE .=. (intE 0))+             (itE .<. (arraySize arg))+             (CUnary CPostIncOp itE)+             (putExprStat+             $ printfE [ stringE $ printFormat pconfig typ " "+                       , index (arrayData arg) itE ])      putString "]\n"   where putString s = putExprStat $ printfE [stringE s] +-- bool and unit+printCG _ (SData (STyCon sym)  _) arg Nothing =+  case ssymbolVal sym of+    "Unit" -> putExprStat $ printfE [stringE "()\n"]+    "Bool" -> ifCG (datumIndex arg .==. (intE 0))+                   (putExprStat $ printfE [stringE "true\n"])+                   (putExprStat $ printfE [stringE "false\n"])+    _ -> error $ show sym+ printCG pconfig SProb arg Nothing =   putExprStat $ printfE                       [ stringE $ printFormat pconfig SProb "\n"@@ -380,6 +386,10 @@               [ stringE $ printFormat pconfig typ "\n"               , arg ] +-- we should only have a number of samples if it a measure+printCG _ _ _ (Just _) = error "this should not happen"++ printFormat :: PrintConfig -> Sing (a :: Hakaru) -> (String -> String) printFormat _ SInt         = \s -> "%d" ++ s printFormat _ SNat         = \s -> "%d" ++ s@@ -420,7 +430,7 @@     let varMs = foldMap11 (\v -> [mkVarDecl v =<< createIdent' "param" v]) vars         typ   = typeOf abt'     in  do argDecls <- sequence varMs-           funCG (head . buildType $ typ) name argDecls $+           funCG (buildType typ) name argDecls $              (putStat . CReturn . Just) =<< flattenWithName' abt' "out"    -- do at top level

@@ -1,12 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP+           , DataKinds+           , OverloadedStrings+           , FlexibleContexts+           #-} module Language.Hakaru.Command where  import           Language.Hakaru.Syntax.ABT import qualified Language.Hakaru.Syntax.AST as T import           Language.Hakaru.Parser.Import (expandImports)-import           Language.Hakaru.Parser.Parser hiding (style)+import           Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports) import           Language.Hakaru.Parser.SymbolResolve (resolveAST) import           Language.Hakaru.Syntax.TypeCheck @@ -20,6 +22,7 @@ import           System.IO (stderr) import           System.Environment (getArgs) import           Data.Monoid ((<>),mconcat)+import           System.FilePath (takeDirectory)  #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative   (Applicative(..), (<$>))@@ -29,25 +32,52 @@  parseAndInfer :: Text.Text               -> Either Text.Text (TypedAST (TrivialABT T.Term))-parseAndInfer x =+parseAndInfer x = parseAndInferWithMode x LaxMode++parseAndInferWithMode+  :: ABT T.Term abt+  => Text.Text+  -> TypeCheckMode+  -> Either Text.Text (TypedAST abt)+parseAndInferWithMode x mode =     case parseHakaru x of     Left  err  -> Left (Text.pack . show $ err)     Right past ->         let m = inferType (resolveAST past) in-        runTCM m (splitLines x) LaxMode+        runTCM m (splitLines x) mode -parseAndInfer' :: Text.Text+-- The filepath from which the text came and the text itself. If the filepath is+-- Nothing, imports are searched for in the current directory.+data Source = Source { file :: Maybe FilePath, source :: Text.Text }++sourceInput :: Source -> Maybe (Vector Text.Text)+sourceInput = splitLines . source++noFileSource :: Text.Text -> Source+noFileSource = Source Nothing++fileSource :: FilePath -> Text.Text -> Source+fileSource = Source . Just++parseAndInfer' :: Source                -> IO (Either Text.Text (TypedAST (TrivialABT T.Term)))-parseAndInfer' x =+parseAndInfer' s = parseAndInferWithMode' s LaxMode++parseAndInferWithMode'+  :: ABT T.Term abt+  => Source+  -> TypeCheckMode+  -> IO (Either Text.Text (TypedAST abt))+parseAndInferWithMode' (Source dir x) mode =     case parseHakaruWithImports x of     Left  err  -> return . Left $ Text.pack . show $ err     Right past -> do-      past' <- runExceptT (expandImports past)+      past' <- runExceptT (expandImports (fmap takeDirectory dir) past)       case past' of         Left err     -> return . Left $ Text.pack . show $ err         Right past'' -> do           let m = inferType (resolveAST past'')-          return (runTCM m (splitLines x) LaxMode)+          return (runTCM m (splitLines x) mode)  parseAndInferWithDebug     :: Bool@@ -75,6 +105,9 @@ readFromFile :: String -> IO Text.Text readFromFile "-" = U.getContents readFromFile x   = U.readFile x++readFromFile' :: String -> IO Source+readFromFile' x = Source (if x=="-" then Nothing else Just x) <$> readFromFile x  simpleCommand :: (Text.Text -> IO ()) -> Text.Text -> IO () simpleCommand k fnName = 

@@ -85,10 +85,10 @@     ( lam_     -- * the Hakaru API     , disintegrateWithVar-    , disintegrate+    , disintegrate, disintegrateInCtx     , densityWithVar-    , density-    , observe+    , density, densityInCtx+    , observe, observeInCtx     , determine          -- * Implementation details@@ -128,6 +128,7 @@ import Language.Hakaru.Syntax.Datum import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchResult(..), matchBranches) import Language.Hakaru.Syntax.ABT+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx) import Language.Hakaru.Evaluation.Types import Language.Hakaru.Evaluation.Lazy import Language.Hakaru.Evaluation.DisintegrationMonad@@ -170,13 +171,14 @@ -- this note should be deleted.] disintegrateWithVar     :: (ABT Term abt)-    => Text.Text+    => TransformCtx+    -> Text.Text     -> Sing a     -> abt '[] ('HMeasure (HPair a b))     -> [abt '[] (a ':-> 'HMeasure b)]-disintegrateWithVar hint typ m =+disintegrateWithVar ctx hint typ m =     let x = Variable hint (nextFreeOrBind m) typ-    in map (lam_ x) . flip runDis [Some2 m, Some2 (var x)] $ do+    in map (lam_ x) . flip (runDisInCtx ctx) [Some2 m, Some2 (var x)] $ do         ab <- perform m #ifdef __TRACE_DISINTEGRATE__         ss <- getStatements@@ -203,16 +205,26 @@  -- | A variant of 'disintegrateWithVar' which automatically computes -- the type via 'typeOf'.-disintegrate+disintegrateInCtx     :: (ABT Term abt)-    => abt '[] ('HMeasure (HPair a b))+    => TransformCtx+    -> abt '[] ('HMeasure (HPair a b))     -> [abt '[] (a ':-> 'HMeasure b)]-disintegrate m =+disintegrateInCtx ctx m =     disintegrateWithVar+        ctx         Text.empty         (fst . sUnPair . sUnMeasure $ typeOf m) -- TODO: change the exception thrown form 'typeOf' so that we know it comes from here         m +-- | A variant of 'disintegrateInCtx' which takes the context to be the minimal+-- one. Calling this function is only really valid on top-level programs, or+-- subprograms in which the enclosing program doesn't bind any variables.+disintegrate+    :: (ABT Term abt)+    => abt '[] ('HMeasure (HPair a b))+    -> [abt '[] (a ':-> 'HMeasure b)]+disintegrate = disintegrateInCtx minimalCtx  -- | Return the density function for a given measure. The first two -- arguments give the hint and type of the lambda-bound variable@@ -224,40 +236,55 @@ -- we should make it into a Haskell function instead. densityWithVar     :: (ABT Term abt)-    => Text.Text+    => TransformCtx+    -> Text.Text     -> Sing a     -> abt '[] ('HMeasure a)     -> [abt '[] (a ':-> 'HProb)]-densityWithVar hint typ m =+densityWithVar ctx hint typ m =     let x = Variable hint (nextFree m `max` nextBind m) typ-    in (lam_ x . E.total) <$> observe m (var x)+    in (lam_ x . E.total) <$> observeInCtx ctx m (var x)   -- | A variant of 'densityWithVar' which automatically computes the -- type via 'typeOf'.-density+densityInCtx     :: (ABT Term abt)-    => abt '[] ('HMeasure a)+    => TransformCtx+    -> abt '[] ('HMeasure a)     -> [abt '[] (a ':-> 'HProb)]-density m =+densityInCtx ctx m =     densityWithVar+        ctx         Text.empty         (sUnMeasure $ typeOf m)         m +density+    :: (ABT Term abt)+    => abt '[] ('HMeasure a)+    -> [abt '[] (a ':-> 'HProb)]+density = densityInCtx minimalCtx  -- | Constrain a measure such that it must return the observed -- value. In other words, the resulting measure returns the observed -- value with weight according to its density in the original -- measure, and gives all other values weight zero.+observeInCtx+    :: (ABT Term abt)+    => TransformCtx+    -> abt '[] ('HMeasure a)+    -> abt '[] a+    -> [abt '[] ('HMeasure a)]+observeInCtx ctx m x =+    runDisInCtx ctx (constrainOutcome x m >> return x) [Some2 m, Some2 x]+ observe     :: (ABT Term abt)     => abt '[] ('HMeasure a)     -> abt '[] a     -> [abt '[] ('HMeasure a)]-observe m x =-    runDis (constrainOutcome x m >> return x) [Some2 m, Some2 x]-+observe = observeInCtx minimalCtx  -- | Arbitrarily choose one of the possible alternatives. In the -- future, this function should be replaced by a better one that@@ -548,8 +575,11 @@             constrainValue  (P.coerceTo_ c v0) e1         NaryOp_     o    es        -> constrainNaryOp v0 o es         PrimOp_     o :$ es        -> constrainPrimOp v0 o es-        Expect  :$ e1 :* e2 :* End -> error "TODO: constrainValue{Expect}" +        Transform_ t :$ _            -> error $+          concat["constrainValue{", show t, "}"+                ,": cannot yet disintegrate transforms; expand them first"]+         Case_ e bs ->             -- First we try going forward on the scrutinee, to make             -- pretty resulting programs; but if that doesn't work@@ -797,7 +827,8 @@     -- what the old finally-tagless code seems to have been doing.     -- But is that right, or should they really be @return ()@?     go :: MeasureOp typs a -> SArgs abt args -> Dis abt ()-    go Lebesgue    = \End               -> bot -- TODO: see note above+    go Lebesgue    = \(e1 :* e2 :* End) ->+        constrainValue v0 (P.lebesgue' e1 e2)     go Counting    = \End               -> bot -- TODO: see note above     go Categorical = \(e1 :* End)       ->         constrainValue v0 (P.categorical e1)@@ -990,6 +1021,8 @@     go Asinh     = \(e1 :* End)       -> error_TODO "Asinh"     go Acosh     = \(e1 :* End)       -> error_TODO "Acosh"     go Atanh     = \(e1 :* End)       -> error_TODO "Atanh"+    go Choose    = \(e1 :* e2 :* End) -> error_TODO "Choose"+    go Floor     = \(e1 :* End)       -> error_TODO "Floor"     go RealPow   = \(e1 :* e2 :* End) ->         -- TODO: There's a discrepancy between @(**)@ and @pow_@ in         -- the old code...@@ -1208,8 +1241,10 @@     -> Dis abt () constrainOutcomeMeasureOp v0 = go     where-    -- Per the paper-    go Lebesgue = \End -> return ()+    go Lebesgue = \(lo :* hi :* End) -> do+        -- TODO: optimize the cases where lo is -∞ or hi is ∞+        v0' <- emitLet' v0+        pushGuard (lo P.<= v0' P.&& v0' P.<= hi)      -- TODO: I think, based on Hakaru v0.2.0     go Counting = \End -> return ()

@@ -31,7 +31,7 @@     -- * The disintegration monad     -- ** List-based version       getStatements, putStatements-    , ListContext(..), Ans, Dis(..), runDis+    , ListContext(..), Ans, Dis(..), runDis, runDisInCtx     -- ** TODO: IntMap-based version          -- * Operators on the disintegration monad@@ -107,6 +107,7 @@ import Language.Hakaru.Syntax.Datum import Language.Hakaru.Syntax.DatumABT import Language.Hakaru.Syntax.TypeOf+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx) import Language.Hakaru.Syntax.ABT import qualified Language.Hakaru.Syntax.Prelude as P import Language.Hakaru.Evaluation.Types@@ -301,11 +302,13 @@ -- We use 'Some2' on the inputs because it doesn't matter what their -- type or locally-bound variables are, so we want to allow @f@ to -- contain terms with different indices.-runDis :: (ABT Term abt, F.Foldable f)-    => Dis abt (abt '[] a)+runDisInCtx+    :: (ABT Term abt, F.Foldable f)+    => TransformCtx+    -> Dis abt (abt '[] a)     -> f (Some2 abt)     -> [abt '[] ('HMeasure a)]-runDis d es =+runDisInCtx ctx d es =     m0 [] c0 (ListContext i0 []) emptyAssocs     where     (Dis m0) = d >>= residualizeLocs@@ -316,7 +319,14 @@     -- that redex by changing the type of 'residualizeListContext'...     c0 (e,rho) ss _ = [residualizeListContext ss rho (syn(Dirac :$ e :* End))]                   -    i0 = maxNextFree es+    i0 = maxNextFree es `max` nextFreeVar ctx++runDis+    :: (ABT Term abt, F.Foldable f)+    => Dis abt (abt '[] a)+    -> f (Some2 abt)+    -> [abt '[] ('HMeasure a)]+runDis = runDisInCtx minimalCtx  {----------------------------------------------------------------------------------   

@@ -48,6 +48,7 @@ import Language.Hakaru.Syntax.ABT      (ABT(..), caseVarSyn, subst, maxNextFreeOrBind) import Language.Hakaru.Syntax.Variable (memberVarSet) import Language.Hakaru.Syntax.AST      hiding (Expect)+import Language.Hakaru.Syntax.Transform (TransformCtx(..)) import Language.Hakaru.Evaluation.Types import Language.Hakaru.Evaluation.Lazy (evaluate) import Language.Hakaru.Evaluation.PEvalMonad (ListContext(..))@@ -120,13 +121,14 @@     :: forall abt f a     .  (ABT Term abt, F.Foldable f)     => Expect abt (abt '[] a)+    -> TransformCtx     -> abt '[a] 'HProb     -> f (Some2 abt)     -> abt '[] 'HProb-runExpect (Expect m) f es =+runExpect (Expect m) ctx f es =     m c0 h0     where-    i0   = nextFreeOrBind f `max` maxNextFreeOrBind es+    i0   = maximum [nextFreeOrBind f, maxNextFreeOrBind es, nextFreeVar ctx]     h0   = ListContext i0 []     c0 e =         residualizeExpectListContext $

@@ -59,7 +59,7 @@ import Language.Hakaru.Syntax.TypeOf import Language.Hakaru.Syntax.AST import Language.Hakaru.Syntax.Datum-import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchResult(..), matchBranches, MatchState(..), matchTopPattern)+import Language.Hakaru.Syntax.DatumCase (DatumEvaluator, MatchState(..), matchTopPattern) import Language.Hakaru.Syntax.ABT import Language.Hakaru.Evaluation.Types import qualified Language.Hakaru.Syntax.Prelude as P@@ -121,7 +121,7 @@         -- We don't bother evaluating these, even though we could...         Integrate :$ e1 :* e2 :* e3 :* End ->             return . Head_ $ WIntegrate e1 e2 e3-        Summate h1 h2 :$ e1 :* e2 :* e3 :* End ->+        Summate _ _ :$ _ :* _ :* _ :* End ->             return . Neutral $ syn t             --return . Head_ $ WSummate   e1 e2 e3 @@ -154,17 +154,12 @@         ArrayOp_ o :$ es -> evaluateArrayOp evaluate_ o es         PrimOp_  o :$ es -> evaluatePrimOp  evaluate_ o es -        -- BUG: avoid the chance of looping in case 'E.expect' residualizes!-        -- TODO: use 'evaluate' in 'E.expect' for the evaluation of @e1@-        Expect :$ e1 :* e2 :* End ->-            error "TODO: evaluate{Expect}: unclear how to handle this without cyclic dependencies"-        {--        -- BUG: can't call E.expect because of cyclic dependency-            evaluate_ . E.expect e1 $ \e3 ->-                syn (Let_ :$ e3 :* e2 :* End)-        -}+        Transform_ tt :$ _ -> error $+            concat ["TODO: evaluate{", show tt, "}"+                   ,": cannot evaluate transforms; expand them first"]          Case_ e bs -> evaluateCase_ e bs+        -- Bucket_ _ _ _ _ -> error "What oh what to do with a Bucket here?"          _ :$ _ -> error "evaluate: the impossible happened" @@ -288,8 +283,8 @@ nor  x y = not (x || y)  -- BUG: no Floating instance for LogFloat (nor NonNegativeRational), so can't actually use this...-natRoot :: (Floating a) => a -> Nat -> a-natRoot x y = x ** recip (fromIntegral (fromNat y))+-- natRoot :: (Floating a) => a -> Nat -> a+-- natRoot x y = x ** recip (fromIntegral (fromNat y))   ----------------------------------------------------------------@@ -443,8 +438,9 @@             Head_ (WArrayLiteral es) -> return . Head_ . WLiteral .                                         primCoerceFrom (Signed HRing_Int) .                                         LInt . toInteger $ length es+            Head_ _ -> error "Got something odd when evaluating an array" -    go (Reduce _) = \(e1 :* e2 :* e3 :* End) ->+    go (Reduce _) = \(_ :* _ :* _ :* End) ->         error "TODO: evaluateArrayOp{Reduce}"  ----------------------------------------------------------------@@ -546,10 +542,12 @@     go Asinh     (e1 :* End)       = neu1 P.asinh e1     go Acosh     (e1 :* End)       = neu1 P.acosh e1     go Atanh     (e1 :* End)       = neu1 P.atanh e1+    go Floor      (e1 :* End)      = neu1 P.floor e1      -- TODO: deal with how we have better types for these three ops than Haskell does...     -- go RealPow   (e1 :* e2 :* End) = rr2 (**) (P.**) e1 e2     go RealPow   (e1 :* e2 :* End) = neu2 (P.**) e1 e2+    go Choose    (e1 :* e2 :* End) = neu2 (P.choose) e1 e2      -- HACK: these aren't actually neutral!     -- BUG: we should try to cancel out @(exp . log)@ and @(log . exp)@@@ -612,7 +610,7 @@         HEq_Int    -> rr2 (==) (P.==)         HEq_Prob   -> rr2 (==) (P.==)         HEq_Real   -> rr2 (==) (P.==)-        HEq_Array aEq -> error "TODO: rrEqual{HEq_Array}"+        HEq_Array _ -> error "TODO: rrEqual{HEq_Array}"         HEq_Bool   -> rr2 (==) (P.==)         HEq_Unit   -> rr2 (==) (P.==)         HEq_Pair   aEq bEq ->@@ -645,7 +643,7 @@                                     | reify va  -> wb                                     | otherwise -> Head_ $ WDatum dFalse -        HEq_Either aEq bEq -> error "TODO: rrEqual{HEq_Either}"+        HEq_Either _ _ -> error "TODO: rrEqual{HEq_Either}"      rrLess         :: forall b. HOrd b -> abt '[] b -> abt '[] b -> m (Whnf abt HBool)@@ -655,10 +653,10 @@         HOrd_Int    -> rr2 (<) (P.<)         HOrd_Prob   -> rr2 (<) (P.<)         HOrd_Real   -> rr2 (<) (P.<)-        HOrd_Array aOrd -> error "TODO: rrLess{HOrd_Array}"+        HOrd_Array _ -> error "TODO: rrLess{HOrd_Array}"         HOrd_Bool   -> rr2 (<) (P.<)         HOrd_Unit   -> rr2 (<) (P.<)-        HOrd_Pair aOrd bOrd ->+        HOrd_Pair _ _ ->             \e1 e2 -> do                 w1 <- evaluate_ e1                 w2 <- evaluate_ e2@@ -672,11 +670,11 @@                             return . Neutral                                 $ P.primOp2_ (Less theOrd) (fromHead v1) e2'                         Head_ v2 -> do-                            let (v1a, v1b) = reifyPair v1-                            let (v2a, v2b) = reifyPair v2+                            let (_, _) = reifyPair v1+                            let (_, _) = reifyPair v2                             error "TODO: rrLess{HOrd_Pair}"                             -- BUG: The obvious recursion won't work because we need to know when the first components are equal before recursing (to implement lexicographic ordering). We really need a ternary comparison operator like 'compare'.-        HOrd_Either aOrd bOrd -> error "TODO: rrLess{HOrd_Either}"+        HOrd_Either _ _ -> error "TODO: rrLess{HOrd_Either}"   ----------------------------------------------------------------

@@ -394,7 +394,6 @@                     CoerceTo_ c' :$ es' ->                         case es' of                         e' :* End -> Just $ P.coerceTo_ (c . c') e'-                        _ -> error "coerceTo@Whnf: the impossible happened"                     _ -> Nothing         Head_ v ->             case v of@@ -415,7 +414,6 @@                     UnsafeFrom_ c' :$ es' ->                         case es' of                         e' :* End -> Just $ P.unsafeFrom_ (c' . c) e'-                        _ -> error "unsafeFrom@Whnf: the impossible happened"                     _ -> Nothing         Head_ v ->             case v of@@ -874,7 +872,7 @@      substVar :: Variable a -> abt '[] a              -> (forall b'. Variable b' -> m (abt '[] b'))-    substVar x e = return . var+    substVar _ _ = return . var       extFreeVars :: abt xs a -> m (VarSet (KindOf a))@@ -930,7 +928,7 @@         -- can return for them because the variables are         -- untouchable\/abstract.         SStuff1 _ _ _ -> Just . return . Neutral $ var x-        SGuard ys pat scrutinee i -> Just . return . Neutral $ var x+        SGuard _ _ _ _ -> Just . return . Neutral $ var x   -- | A simple 'CaseEvaluator' which uses the 'DatumEvaluator' to

@@ -7,6 +7,7 @@            , NoImplicitPrelude            , ScopedTypeVariables            , FlexibleContexts+           , ViewPatterns            #-}  {-# OPTIONS_GHC -Wall -fwarn-tabs #-}@@ -25,10 +26,10 @@ module Language.Hakaru.Expect     ( normalize     , total-    , expect+    , expect, expectInCtx, determineExpect     ) where -import           Prelude               (($), (.), error, reverse)+import           Prelude               (($), (.), error, reverse, Maybe(..)) import qualified Data.Text             as Text import           Data.Functor          ((<$>)) import qualified Data.Foldable         as F@@ -43,6 +44,7 @@ import Language.Hakaru.Syntax.ABT import Language.Hakaru.Syntax.Datum import Language.Hakaru.Syntax.DatumABT+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx) import Language.Hakaru.Syntax.AST               hiding (Expect) import qualified Language.Hakaru.Syntax.AST     as AST import Language.Hakaru.Syntax.TypeOf            (typeOf)@@ -88,9 +90,27 @@     => abt '[] ('HMeasure a)     -> abt '[a] 'HProb     -> abt '[] 'HProb-expect e f = runExpect (expectTerm e) f [Some2 e, Some2 f]+expect = expectInCtx minimalCtx +expectInCtx+    :: (ABT Term abt)+    => TransformCtx+    -> abt '[] ('HMeasure a)+    -> abt '[a] 'HProb+    -> abt '[] 'HProb+expectInCtx ctx e f = runExpect (expectTerm e) ctx f [Some2 e, Some2 f] +-- | A helper which converts residualized `expect' to a `Nothing' instead.+determineExpect+    :: (ABT Term abt)+    => abt '[] 'HProb+    -> Maybe (abt '[] 'HProb)+determineExpect e =+  case e of+    (viewABT -> Syn (AST.Transform_ AST.Expect :$ _)) -> Nothing+    r -> Just r++ residualizeExpect     :: (ABT Term abt)     => abt '[] ('HMeasure a)@@ -99,7 +119,7 @@     -- BUG: is this what we really mean? or do we actually mean the old 'emit' version?     x <- freshVar Text.empty (sUnMeasure $ typeOf e)     unsafePush (SStuff1 (Location x) (\c ->-        syn (AST.Expect :$ e :* bind x c :* End)) [])+        syn (AST.Transform_ AST.Expect :$ e :* bind x c :* End)) [])     return $ var x {- residualizeExpect e = do@@ -303,8 +323,10 @@     => MeasureOp typs a     -> SArgs abt args     -> Expect abt (abt '[] a)-expectMeasureOp Lebesgue = \End ->-    var <$> pushIntegrate P.negativeInfinity P.infinity+expectMeasureOp Lebesgue = \(lo :* hi :* End) -> do +    lo' <- var <$> pushLet lo+    hi' <- var <$> pushLet hi+    var <$> pushIntegrate lo' hi'  expectMeasureOp Counting = \End ->     var <$> pushSummate P.negativeInfinity P.infinity expectMeasureOp Categorical = \(ps :* End) -> do

@@ -2,6 +2,10 @@            , TypeOperators            , NoImplicitPrelude            , FlexibleContexts+           , GADTs+           , TypeFamilies+           , FlexibleInstances+           , ViewPatterns            #-}  {-# OPTIONS_GHC -Wall -fwarn-tabs #-}@@ -20,8 +24,8 @@ ---------------------------------------------------------------- module Language.Hakaru.Inference     ( priorAsProposal-    , mh-    , mcmc+    , mh, mh'+    , mcmc, mcmc'     , gibbsProposal     , slice     , sliceX@@ -33,17 +37,25 @@     ) where  import Prelude (($), (.), error, Maybe(..), return)+import qualified Prelude as P import Language.Hakaru.Types.DataKind import Language.Hakaru.Types.Sing import Language.Hakaru.Syntax.AST (Term) import Language.Hakaru.Syntax.ABT (ABT, binder) import Language.Hakaru.Syntax.Prelude+import Language.Hakaru.Syntax.Transform (TransformCtx(..), minimalCtx) import Language.Hakaru.Syntax.TypeOf import Language.Hakaru.Expect (expect, normalize)-import Language.Hakaru.Disintegrate (determine, density, disintegrate)+import Language.Hakaru.Disintegrate (determine+                                    ,density, densityInCtx+                                    ,disintegrate, disintegrateInCtx)+import Language.Hakaru.Syntax.IClasses (TypeEq(..), JmEq1(..))  import qualified Data.Text as Text+import Control.Monad.Except (MonadError(..)) +import qualified Control.Applicative as P+ ---------------------------------------------------------------- ---------------------------------------------------------------- priorAsProposal@@ -68,34 +80,48 @@ -- -- TODO: the @a@ type should be pure (aka @a ~ Expect' a@ in the old parlance). -- BUG: get rid of the SingI requirements due to using 'lam'-mh  :: (ABT Term abt)-    => abt '[] (a ':-> 'HMeasure a)-    -> abt '[] ('HMeasure a)-    -> abt '[] (a ':-> 'HMeasure (HPair a 'HProb))-mh proposal target =-    case determine $ density target of-    Nothing -> error "mh: couldn't get density"-    Just theDensity ->-        let_ theDensity $ \mu ->+mh'  :: (ABT Term abt)+     => TransformCtx+     -> abt '[] (a ':-> 'HMeasure a)+     -> abt '[] ('HMeasure a)+     -> Maybe (abt '[] (a ':-> 'HMeasure (HPair a 'HProb)))+mh' ctx proposal target =+        let_ P.<$> (determine $ densityInCtx ctx target) P.<*> P.pure (\mu ->         lam' $ \old ->             app proposal old >>= \new ->-            dirac $ pair' new (mu `app` {-pair-} new {-old-} / mu `app` {-pair-} old {-new-})+            dirac $ pair' new (mu `app` {-pair-} new {-old-} / mu `app` {-pair-} old {-new-}))   where lam' f = lamWithVar Text.empty (sUnMeasure $ typeOf target) f         pair'  = pair_ (sUnMeasure $ typeOf target) SProb +mh  :: (ABT Term abt)+     => abt '[] (a ':-> 'HMeasure a)+     -> abt '[] ('HMeasure a)+     -> abt '[] (a ':-> 'HMeasure (HPair a 'HProb))+mh proposal target =+  P.maybe (error "mh: couldn't compute density") P.id $+  mh' minimalCtx proposal target+ -- BUG: get rid of the SingI requirements due to using 'lam' in 'mh'-mcmc :: (ABT Term abt)-    => abt '[] (a ':-> 'HMeasure a)-    -> abt '[] ('HMeasure a)-    -> abt '[] (a ':-> 'HMeasure a)-mcmc proposal target =-    let_ (mh proposal target) $ \f ->+mcmc' :: (ABT Term abt)+      => TransformCtx+      -> abt '[] (a ':-> 'HMeasure a)+      -> abt '[] ('HMeasure a)+      -> Maybe (abt '[] (a ':-> 'HMeasure a))+mcmc' ctx proposal target =+    let_ P.<$> mh' ctx proposal target P.<*> P.pure (\f ->     lamWithVar Text.empty (sUnMeasure $ typeOf target) $ \old ->         app f old >>= \new_ratio ->         new_ratio `unpair` \new ratio ->         bern (min (prob_ 1) ratio) >>= \accept ->-        dirac (if_ accept new old)+        dirac (if_ accept new old)) +mcmc :: (ABT Term abt)+     => abt '[] (a ':-> 'HMeasure a)+     -> abt '[] ('HMeasure a)+     -> abt '[] (a ':-> 'HMeasure a)+mcmc proposal target =+  P.maybe (error "mcmc: couldn't compute density") P.id $+  mcmc' minimalCtx proposal target  gibbsProposal     :: (ABT Term abt, SingI a, SingI b)

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances+{-# LANGUAGE CPP+           , FlexibleInstances            , FlexibleContexts            , DeriveDataTypeable            , DataKinds@@ -6,7 +7,11 @@            , RecordWildCards            , ViewPatterns            , LambdaCase-           , DeriveFunctor, DeriveFoldable, DeriveTraversable +           , KindSignatures+           , TypeOperators+           , GADTs+           , RankNTypes+           , DeriveFunctor, DeriveFoldable, DeriveTraversable            #-}  {-# OPTIONS_GHC -Wall -fwarn-tabs #-}@@ -17,51 +22,62 @@ -- Stability   :  experimental -- Portability :  GHC-only ----- Take strings from Maple and interpret them in Haskell (Hakaru), --- in a type-safe way. +-- Take strings from Maple and interpret them in Haskell (Hakaru),+-- in a type-safe way. -----------------------------------------------------------------module Language.Hakaru.Maple +module Language.Hakaru.Maple   ( MapleException(..)   , MapleOptions(..)+  , MapleCommand(MapleCommand)   , defaultMapleOptions   , sendToMaple, sendToMaple'   , maple-  ) where -    -import Control.Exception+  ) where++import Control.Exception (Exception, throw) import Control.Monad (when)+import Data.Typeable (Typeable)  import qualified Language.Hakaru.Pretty.Maple as Maple  import Language.Hakaru.Parser.Maple import Language.Hakaru.Parser.AST (Name)-import qualified Language.Hakaru.Parser.SymbolResolve as SR (resolveAST', fromVarSet)+import Language.Hakaru.Pretty.Concrete (prettyType)+import qualified Language.Hakaru.Parser.SymbolResolve as SR+                  (resolveAST', fromVarSet)  import Language.Hakaru.Types.Sing+import Language.Hakaru.Types.DataKind import Language.Hakaru.Syntax.ABT import Language.Hakaru.Syntax.AST import Language.Hakaru.Syntax.TypeCheck import Language.Hakaru.Syntax.TypeOf-import Language.Hakaru.Syntax.Command +import Language.Hakaru.Syntax.IClasses  import Language.Hakaru.Evaluation.ConstantPropagation -import Data.Typeable (Typeable)- import System.MapleSSH (maple) import System.IO import Data.Text (pack)-import qualified Data.Map as M -import Data.List (intercalate) +import qualified Data.Map as M+import Data.List (isInfixOf, intercalate)+import Data.Char (toLower)+import Data.Function (on)  import Data.Foldable (Foldable) import Data.Traversable (Traversable) +#if __GLASGOW_HASKELL__ < 710+import Data.Monoid (mempty)+#endif+ -----------------------------------------------------------------data MapleException       +data MapleException   = MapleInterpreterException String String   | MapleInputTypeMismatch String String   | MapleUnknownCommand String+  | MapleAmbiguousCommand String [String]+  | MultipleErrors [MapleException]       deriving Typeable  instance Exception MapleException@@ -77,12 +93,19 @@       concat["Maple command ", command, " does not take input of type ", ty]      show (MapleUnknownCommand command) =        concat["Maple command ", command, " does not exist"] +    show (MapleAmbiguousCommand str cmds) =+      concat [ "Ambiguous command\n"+             , str, " could refer to any of\n"+             , intercalate "," cmds ]+    show (MultipleErrors es) =+      concat $ "Multiple errors" : map (("\n\n" ++) . show) es  data MapleOptions nm = MapleOptions    { command   :: nm    , debug     :: Bool    , timelimit :: Int    , extraOpts :: M.Map String String +  , context   :: TransformCtx   } deriving (Functor, Foldable, Traversable)   defaultMapleOptions :: MapleOptions () @@ -90,32 +113,113 @@   { command = ()       , debug = False    , timelimit = 90-  , extraOpts = M.empty }+  , extraOpts = M.empty+  , context = mempty } +--------------------------------------------------------------------------------++-- | Maple commands operate on closed terms and take a single argument, and can+--   be applied under functions.+data MapleCommand (i :: Hakaru) (o :: Hakaru) where+  MapleCommand :: !(Transform '[ '( '[], i ) ] o) -> MapleCommand i o+  UnderFun     :: !(MapleCommand i o) -> MapleCommand (x ':-> i) (x ':-> o)++typeOfMapleCommand :: MapleCommand i o -> Sing i -> Sing o+typeOfMapleCommand (MapleCommand t) i =+  typeOfTransform t (Pw (Lift1 ()) i :* End)+typeOfMapleCommand (UnderFun c) (SFun x i) =+  SFun x (typeOfMapleCommand c i)++newtype CommandMatcher+   = CommandMatcher (forall i . Sing i+                             -> Either MapleException (Some1 (MapleCommand i)))++infixl 3 <-|>+(<-|>) :: Either MapleException x+       -> Either MapleException x+       -> Either MapleException x+(<-|>) (Left x) (Left y) =+  Left $ MultipleErrors (unnest x ++ unnest y) where+    unnest (MultipleErrors e) = concatMap unnest e+    unnest                 e  = [e]+(<-|>) Left{}         x  = x+(<-|>) x@Right{}      _  = x++matchUnderFun :: CommandMatcher -> CommandMatcher+matchUnderFun (CommandMatcher k) = CommandMatcher go where+  go :: Sing i -> Either MapleException (Some1 (MapleCommand i))+  go ty@(SFun _ i) =+    fmap (\(Some1 c) -> Some1 (UnderFun c)) (go i) <-|>+    k ty+  go ty =+    k ty <-|>+    Left (MapleInputTypeMismatch "x -> y" (show $ prettyType 0 ty))++mapleCommands+  :: [ (String, CommandMatcher) ]+mapleCommands =+  [ ("Simplify"+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Simplify)+  , ("Reparam"+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Reparam)+  , ("Summarize"+    , CommandMatcher $ \_ -> return $ Some1 $ MapleCommand Summarize)+  , ("Disintegrate"+    , matchUnderFun $ CommandMatcher $ \i ->+        case i of+          SMeasure (SData (STyApp (STyApp+              (STyCon (jmEq1 sSymbol_Pair -> Just Refl)) _) _) _) ->+            return $ Some1 $ MapleCommand $ Disint InMaple+          _ -> Left $+                  MapleInputTypeMismatch "measure (pair (a,b))"+                                         (show $ prettyType 0 i))+  ]++matchCommandName :: String -> Sing i+                 -> Either MapleException (Some1 (MapleCommand i))+matchCommandName s i =+  case filter ((isInfixOf `on` map toLower) s . fst) mapleCommands of+    [(_,CommandMatcher m)]+       -> m i+    [] -> Left $ MapleUnknownCommand s+    cs -> Left $ MapleAmbiguousCommand s (map fst cs)++nameOfMapleCommand :: MapleCommand i o -> Either MapleException String+nameOfMapleCommand (MapleCommand t) = nm t where+  nm :: Transform xs x -> Either MapleException String+  nm Simplify         = Right "Simplify"+  nm (Disint InMaple) = Right "Disintegrate"+  nm Summarize        = Right "Summarize"+  nm Reparam          = Right "Reparam"+  nm tt               = Left $ MapleUnknownCommand (show tt)+nameOfMapleCommand (UnderFun c) = nameOfMapleCommand c++--------------------------------------------------------------------------------+ sendToMaple'      :: ABT Term (abt Term)      => MapleOptions String      -> TypedAST (abt Term)      -> IO (TypedAST (abt Term))-sendToMaple' MapleOptions{..} (TypedAST ty expr) = -  commandFromName command ty $ \case -    Left True       -> throw $ MapleInputTypeMismatch command (show ty) -    Left False      -> throw $ MapleUnknownCommand command -    Right (c, ty_o) -> fmap (TypedAST ty_o) (sendToMaple MapleOptions{command=c,..} expr)+sendToMaple' o@MapleOptions{..} (TypedAST typ term) = do+  Some1 cmdT <- either throw return $ matchCommandName command typ+  res        <- sendToMaple o{command=cmdT} term+  return $ TypedAST (typeOf res) res -sendToMaple  +sendToMaple     :: (ABT Term abt)-    => MapleOptions (CommandType c i o) -    -> abt '[] i +    => MapleOptions (MapleCommand i o)+    -> abt '[] i     -> IO (abt '[] o)-sendToMaple MapleOptions{..} e = do +sendToMaple MapleOptions{..} e = do+  nm <- either throw return $ nameOfMapleCommand command   let typ_in = typeOf e-      typ_out = commandIsType command typ_in +      typ_out = typeOfMapleCommand command typ_in        optStr (k,v) = concat["_",k,"=",v]       optsStr =          intercalate "," $          map optStr $ M.assocs $ -        M.insert "command" (ssymbolVal(nameOfCommand command)) extraOpts +        M.insert "command" nm extraOpts        toMaple_ = "use Hakaru, NewSLO in timelimit("                  ++ show timelimit ++ ", RoundTrip("                  ++ Maple.pretty e ++ ", " ++ Maple.mapleType typ_in (", "@@ -131,10 +235,11 @@              (return . constantPropagation) $ do         past <- leftShow $ parseMaple (pack fromMaple)         let m = checkType typ_out-                 (SR.resolveAST' (getNames e) (maple2AST past))+                 (SR.resolveAST' (max (nextFreeOrBind e) (nextFreeVar context))+                                 (getNames e) (maple2AST past))         leftShow $ unTCM m (freeVars e) Nothing UnsafeMode     _ -> throw (MapleInterpreterException toMaple_ fromMaple)-  + leftShow :: forall b c. Show b => Either b c -> Either String c leftShow (Left err) = Left (show err) leftShow (Right x)  = Right x

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP+ {-# LANGUAGE CPP            , GADTs            , DataKinds            , PolyKinds@@ -7,6 +7,11 @@            , TypeFamilies            , TypeOperators            , OverloadedStrings+           , DeriveDataTypeable+           , ScopedTypeVariables+           , RankNTypes+           , FlexibleContexts+           , LambdaCase            #-}  {-# OPTIONS_GHC -Wall -fwarn-tabs #-}@@ -28,88 +33,113 @@ import Language.Hakaru.Syntax.ABT    hiding (Var, Bind) import Language.Hakaru.Syntax.AST     (Literal(..), MeasureOp(..), LCs(), UnLCs ())+import qualified Language.Hakaru.Syntax.AST as T import Language.Hakaru.Syntax.IClasses  #if __GLASGOW_HASKELL__ < 710 import Data.Monoid   (Monoid(..)) #endif -import Data.Text-import Text.Printf+import qualified Data.Text as T import Text.Parsec (SourcePos) import Text.Parsec.Pos+import Data.Generics hiding ((:~:)(..))  -- N.B., because we're not using the ABT's trick for implementing a HOAS API, we can make the identifier strict.-data Name = Name {-# UNPACK #-}!N.Nat {-# UNPACK #-}!Text-    deriving (Read, Show, Eq, Ord)+data Name = Name {-# UNPACK #-}!N.Nat {-# UNPACK #-}!T.Text+    deriving (Read, Show, Eq, Ord, Data, Typeable)  nameID :: Name -> N.Nat nameID (Name i _) = i -hintID :: Name -> Text+hintID :: Name -> T.Text hintID (Name _ t) = t  ---------------------------------------------------------------- ---------------------------------------------------------------- -type Name' = Text+type Name' = T.Text  data Branch' a     = Branch'  (Pattern' Name') (AST' a)     | Branch'' (Pattern' Name)  (AST' a)-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable)  data Pattern' a     = PVar'  a     | PWild'     | PData' (PDatum a)-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable)  data PDatum a = DV Name' [Pattern' a]-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable)  -- Meta stores start and end position for AST in source code data SourceSpan = SourceSpan !SourcePos !SourcePos-    deriving (Eq, Show)--numberLine :: Text -> Int -> Text-numberLine s n = append (pack (printf "%5d| " n)) s+    deriving (Eq, Show, Data, Typeable) -printSourceSpan :: SourceSpan -> V.Vector Text -> Text+printSourceSpan :: SourceSpan -> V.Vector T.Text -> T.Text printSourceSpan (SourceSpan start stop) input-    | sourceLine start == sourceLine stop =-        unlines [ numberLine endLine (sourceLine stop)-                , append "       " textSpan-                ]-    | otherwise                           =-        unlines $ flip fmap [sourceLine start .. sourceLine stop] $ \i ->-            numberLine (input V.! (i - 1)) i-   where endLine  = input V.! (sourceLine stop - 1)-         spanLen  = sourceColumn stop - sourceColumn start-         textSpan =-             append (replicate (sourceColumn start - 1) " ")-                    (replicate spanLen "^")+  = T.unlines (concatMap line [startLine..stopLine])+  where+  line :: Int -> [T.Text]+  line i | (sourceLine start, sourceColumn start) <= (i, 1) &&+           (i, eol) <= (sourceLine stop, sourceColumn stop)+         = [T.empty | i == startLine] +++           [quote '>'] +++           [T.empty | i == stopLine]+         | i == stopLine+         = [T.empty | i == startLine] +++           [quote ' ',+            marking (if i == sourceLine start then sourceColumn start else 1)+                    (if i == sourceLine stop  then sourceColumn stop  else eol)+                    '^']+         | i == sourceLine start+         = [marking (sourceColumn start) eol '.',+            quote ' ']+         | otherwise+         = [quote ' ']+    where numbering = T.pack (show i)+          lining    = input V.! (i-1)+          eol       = T.length lining + 1+          quote c   = spacing (digits - T.length numbering)+                      `T.append` numbering+                      `T.append` T.singleton '|'+                      `T.append` T.singleton c+                      `T.append` lining+  spacing k     = T.replicate k (T.singleton ' ')+  marking l r c = spacing (digits + 1 + l)+                  `T.append` T.replicate (max 1 (r - l)) (T.singleton c)+  startLine     = max 1+                $ sourceLine start+  stopLine      = max startLine+                $ min (V.length input)+                $ (if sourceColumn stop == 1 then pred else id)+                $ sourceLine stop+  digits        = loop stopLine 1+    where loop i res | i < 10    = res+                     | otherwise = (loop $! div i 10) $! (res + 1)  data Literal'     = Nat  Integer     | Int  Integer     | Prob Rational     | Real Rational-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable)  data NaryOp     = And | Or   | Xor     | Iff | Min  | Max     | Sum | Prod-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable) -data ArrayOp = Index_ | Size | Reduce+data ArrayOp = Index_ | Size | Reduce deriving (Data, Typeable)  data TypeAST'     = TypeVar Name'     | TypeApp Name'    [TypeAST']     | TypeFun TypeAST' TypeAST'-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable)  data Reducer' a     = R_Fanout (Reducer' a) (Reducer' a)@@ -117,8 +147,30 @@     | R_Split (AST' a) (Reducer' a) (Reducer' a)     | R_Nop     | R_Add (AST' a)-    deriving (Eq, Show)+    deriving (Eq, Show, Data, Typeable) +data Transform'+    = Observe+    | MH+    | MCMC+    | Disint T.TransformImpl+    | Summarize+    | Simplify+    | Reparam+    | Expect+    deriving (Eq, Show, Data, Typeable)++trFromTyped :: T.Transform as x -> Transform'+trFromTyped = \case+  T.Observe   -> Observe+  T.MH        -> MH+  T.MCMC      -> MCMC+  T.Disint k  -> Disint k+  T.Summarize -> Summarize+  T.Simplify  -> Simplify+  T.Reparam   -> Reparam+  T.Expect    -> Expect+ data AST' a     = Var a     | Lam a TypeAST' (AST' a)@@ -130,13 +182,11 @@     | ULiteral Literal'     | NaryOp NaryOp [AST' a]     | Unit-    | Empty     | Pair (AST' a) (AST' a)     | Array a (AST' a) (AST' a)     | ArrayLiteral [AST' a]     | Index (AST' a) (AST' a)     | Case  (AST' a) [(Branch' a)] -- match-    | Dirac (AST' a)     | Bind  a  (AST' a) (AST' a)     | Plate a  (AST' a) (AST' a)     | Chain a  (AST' a) (AST' a) (AST' a)@@ -144,13 +194,26 @@     | Summate   a (AST' a) (AST' a) (AST' a)     | Product   a (AST' a) (AST' a) (AST' a)     | Bucket    a (AST' a) (AST' a) (Reducer' a)-    | Expect a (AST' a) (AST' a)-    | Observe  (AST' a) (AST' a)+    | Transform Transform' (SArgs' a)     | Msum  [AST' a]     | Data  a [a] [TypeAST'] (AST' a)     | WithMeta (AST' a) SourceSpan-    deriving (Show)+    deriving (Show, Data, Typeable) +newtype SArgs' a = SArgs' [ ([a], AST' a) ]+    deriving (Eq, Show, Data, Typeable)++-- For backwards compatibility+_Expect :: a -> AST' a -> AST' a -> AST' a+_Expect v a b = Transform Expect $ SArgs' $ [ ([], a), ([v], b) ]++withoutMeta :: AST' a -> AST' a+withoutMeta (WithMeta e _) = withoutMeta e+withoutMeta           e    =             e++withoutMetaE :: forall a . Data a => AST' a -> AST' a+withoutMetaE = everywhere (mkT (withoutMeta :: AST' a -> AST' a))+ instance Eq a => Eq (AST' a) where     (Var t)             == (Var t')                 = t    == t'     (Lam n  e1 e2)      == (Lam n' e1' e2')         = n    == n'  &&@@ -171,7 +234,6 @@     (NaryOp op args)    == (NaryOp op' args')       = op   == op' &&                                                       args == args'     Unit                == Unit                     = True-    Empty               == Empty                    = True     (Pair  e1 e2)       == (Pair   e1' e2')         = e1   == e1' &&                                                       e2   == e2'     (Array e1 e2 e3)    == (Array  e1' e2' e3')     = e1   == e1' &&@@ -182,7 +244,6 @@                                                       e2   == e2'     (Case  e1 bs)       == (Case   e1' bs')         = e1   == e1' &&                                                       bs   == bs'-    (Dirac e1)          == (Dirac  e1')             = e1   == e1'     (Bind  e1 e2 e3)    == (Bind   e1' e2' e3')     = e1   == e1' &&                                                       e2   == e2' &&                                                       e3   == e3'@@ -209,11 +270,8 @@                                                       b    == b' &&                                                       c    == c' &&                                                       d    == d'-    (Expect e1 e2 e3)   == (Expect e1' e2' e3')     = e1   == e1' &&-                                                      e2   == e2' &&-                                                      e3   == e3'-    (Observe  e1 e2)    == (Observe    e1' e2')     = e1   == e1' &&-                                                      e2   == e2'+    (Transform t0 es0)  == (Transform t1 es1)       = t0   == t1 &&+                                                      es0  == es1     (Msum  es)          == (Msum   es')             = es   == es'     (Data  n ft ts e)   == (Data   n' ft' ts' e')   = n    == n'  &&                                                       ft   == ft' &&@@ -244,12 +302,13 @@     | Asin       | Acos   | Atan     | Sinh       | Cosh   | Tanh     | Asinh      | Acosh  | Atanh-    | RealPow    | NatPow+    | RealPow    | Choose | NatPow     | Exp        | Log    | Infinity     | GammaFunc  | BetaFunc     | Equal      | Less     | Negate     | Recip     | Abs        | Signum | NatRoot | Erf+    | Floor     deriving (Eq, Show)  data SomeOp op where@@ -278,7 +337,7 @@ data Pattern     = PWild     | PVar Name-    | PDatum Text PCode+    | PDatum T.Text PCode  data PFun     = PKonst Pattern@@ -306,7 +365,7 @@     = Inr (DCode   abt)     | Inl (DStruct abt) -data Datum abt = Datum Text (DCode abt)+data Datum abt = Datum T.Text (DCode abt)  fmapDatum     :: (f '[] 'U -> g '[] 'U)@@ -412,7 +471,6 @@     MeasureOp_    :: SomeOp MeasureOp -> [abt '[] 'U]    -> Term abt 'U     NaryOp_       :: NaryOp           -> [abt '[] 'U]    -> Term abt 'U     Literal_      :: Some1 Literal                       -> Term abt 'U-    Empty_        ::                                        Term abt 'U     Pair_         :: abt '[] 'U       -> abt '[]     'U  -> Term abt 'U     Array_        :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U     ArrayLiteral_ :: [abt '[] 'U]                        -> Term abt 'U@@ -426,12 +484,27 @@     Summate_      :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U     Product_      :: abt '[] 'U       -> abt '[]     'U  -> abt '[ 'U ] 'U -> Term abt 'U     Bucket_       :: abt '[] 'U       -> abt '[]     'U  -> Reducer xs abt 'U -> Term abt 'U-    Expect_       :: abt '[] 'U       -> abt '[ 'U ] 'U  -> Term abt 'U-    Observe_      :: abt '[] 'U       -> abt '[]     'U  -> Term abt 'U+    Transform_    :: T.Transform as x -> SArgs abt as    -> Term abt 'U     Superpose_    :: L.NonEmpty (abt '[] 'U, abt '[] 'U) -> Term abt 'U     Reject_       ::                                        Term abt 'U+    InjTyped      :: (forall abt' . ABT T.Term abt'+                                 => abt' '[] x)          -> Term abt 'U +infixr 5 :*+data SArgs (abt :: [Untyped] -> Untyped -> *) (as :: [([k], k)]) where+  End :: SArgs abt '[]+  (:*) :: !(List2 ToUntyped vars varsu, abt varsu 'U)+       -> !(SArgs abt args)+       -> SArgs abt ( '(vars, a) ': args) +data ToUntyped (x :: k) (y :: Untyped) where+  ToU :: ToUntyped x 'U++instance Functor21 SArgs where+    fmap21 f = \case+      End          -> End+      (m, a) :* as -> (m, f a) :* fmap21 f as+ -- TODO: instance of Traversable21 for Term instance Functor21 Term where     fmap21 f (Lam_       typ e1)    = Lam_       typ    (f e1)@@ -445,7 +518,6 @@     fmap21 f (MeasureOp_ op  es)    = MeasureOp_ op     (fmap f es)     fmap21 f (NaryOp_    op  es)    = NaryOp_    op     (fmap f es)     fmap21 _ (Literal_   v)         = Literal_   v-    fmap21 _ Empty_                 = Empty_     fmap21 f (Pair_      e1  e2)    = Pair_      (f e1) (f e2)     fmap21 f (Array_     e1  e2)    = Array_     (f e1) (f e2)     fmap21 f (ArrayLiteral_  es)    = ArrayLiteral_     (fmap f es)@@ -459,11 +531,16 @@     fmap21 f (Summate_   e1  e2 e3) = Summate_   (f e1) (f e2) (f e3)     fmap21 f (Product_   e1  e2 e3) = Product_   (f e1) (f e2) (f e3)     fmap21 f (Bucket_    e1  e2 e3) = Bucket_    (f e1) (f e2) (fmap21 f e3)-    fmap21 f (Expect_    e1  e2)    = Expect_    (f e1) (f e2)-    fmap21 f (Observe_   e1  e2)    = Observe_   (f e1) (f e2)+    fmap21 f (Transform_ t as)      = Transform_ t (fmap21 f as)     fmap21 f (Superpose_ es)        = Superpose_ (L.map (f *** f) es)     fmap21 _ Reject_                = Reject_+    fmap21 _ (InjTyped x)           = InjTyped x +instance Foldable21 SArgs where+    foldMap21 f = \case+      End          -> mempty+      (_, a) :* as -> f a `mappend` foldMap21 f as+ instance Foldable21 Term where     foldMap21 f (Lam_       _  e1)    = f e1     foldMap21 f (App_       e1 e2)    = f e1 `mappend` f e2@@ -476,7 +553,6 @@     foldMap21 f (MeasureOp_ _  es)    = F.foldMap f es     foldMap21 f (NaryOp_    _  es)    = F.foldMap f es     foldMap21 _ (Literal_   _)        = mempty-    foldMap21 _ Empty_                = mempty     foldMap21 f (Pair_      e1 e2)    = f e1 `mappend` f e2     foldMap21 f (Array_     e1 e2)    = f e1 `mappend` f e2     foldMap21 f (ArrayLiteral_ es)    = F.foldMap f es@@ -490,10 +566,10 @@     foldMap21 f (Summate_   e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3     foldMap21 f (Product_   e1 e2 e3) = f e1 `mappend` f e2 `mappend` f e3     foldMap21 f (Bucket_    e1 e2 e3) = f e1 `mappend` f e2 `mappend` foldMap21 f e3-    foldMap21 f (Expect_    e1 e2)    = f e1 `mappend` f e2-    foldMap21 f (Observe_   e1 e2)    = f e1 `mappend` f e2+    foldMap21 f (Transform_ _ es)     = foldMap21 f es     foldMap21 f (Superpose_ es)       = F.foldMap (\(e1,e2) -> f e1 `mappend` f e2) es     foldMap21 _ Reject_               = mempty+    foldMap21 _ InjTyped{}            = mempty  type U_ABT    = MetaABT SourceSpan Term type AST      = U_ABT '[] 'U

@@ -1,15 +1,15 @@ {-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-}-module Language.Hakaru.Parser.Import where+module Language.Hakaru.Parser.Import (expandImports) where  import           Language.Hakaru.Parser.AST-import           Language.Hakaru.Parser.Parser+import           Language.Hakaru.Parser.Parser (parseHakaruWithImports)  import           Control.Monad.Trans.Except import           Control.Monad.IO.Class import qualified Data.Text                     as T import qualified Data.Text.IO                  as IO-import           Text.Parsec                   hiding (Empty)+import           Text.Parsec  replaceBody :: AST' T.Text -> AST' T.Text -> AST' T.Text replaceBody e1 e2 =@@ -20,11 +20,13 @@       _                 -> e2  expandImports-    :: ASTWithImport' T.Text+    :: Maybe FilePath+    -> ASTWithImport' T.Text     -> ExceptT ParseError IO (AST' T.Text)-expandImports (ASTWithImport' (Import i:is) ast) = do-    file  <- liftIO . IO.readFile . T.unpack $ T.append i ".hk"+expandImports dir (ASTWithImport' (Import i:is) ast) = do+    file  <- liftIO . IO.readFile . T.unpack $+             T.concat $ maybe [] ((:["/"]) . T.pack) dir ++ [ i, ".hk" ]     astIm <- ExceptT . return $ parseHakaruWithImports file-    ast'  <- expandImports astIm-    expandImports (ASTWithImport' is (replaceBody ast' ast))-expandImports (ASTWithImport' [] ast) = return ast+    ast'  <- expandImports dir astIm+    expandImports dir (ASTWithImport' is (replaceBody ast' ast))+expandImports _ (ASTWithImport' [] ast) = return ast

@@ -239,7 +239,7 @@  lesseq :: Parser InertExpr lesseq = do-    text "_Inert_LESSEQ"+    _ <- text "_Inert_LESSEQ"     args <- arg expr     return $ InertArgs Not_                [ InertArgs Less (reverse args)]@@ -317,9 +317,6 @@         [InertName "Datum", InertArgs ExpSeq [InertName h, d]]) =     mapleDatum2AST h d -maple2AST (InertArgs Func [InertName "Lebesgue", _]) =-    Var "lebesgue"- maple2AST (InertArgs Func [InertName "Counting", _]) =     Var "counting" @@ -360,6 +357,8 @@  maple2AST (InertArgs Func         [InertName "piecewise", InertArgs ExpSeq es]) = go es where+  go []           = error "Invalid 0-ary piecewise?"+  go [_]          = error "Invalid 1-ary piecewise?"   go [e1,e2]      = If (maple2AST e1) (maple2AST e2) (ULiteral (Nat 0))   go [e1,e2,e3]   = If (maple2AST e1) (maple2AST e2) (maple2AST e3)   -- BUG! piecewise(a<b,2,a=b,1) doesn't mean piecewise(a<b,2,1) in Maple@@ -485,6 +484,13 @@ maple2AST (InertArgs Less es)  =     foldl App (Var "less")  (map maple2AST es) +-- Special case to undo the "piecewise(x=true,...)" created by our Maple code+-- (in the Hakaru:-make_piece function), to avoid the error produced by Maple+-- "piecewise(x,...)".  (This "=true" is also removed by NewSLO:-applyintegrand+-- if Maple ever substitutes something for x, but that may never happen.)+maple2AST (InertArgs Equal [e, InertName "true"]) = maple2AST e+maple2AST (InertArgs Equal [InertName "true", e]) = maple2AST e+ maple2AST (InertArgs Equal es) =     foldl App (Var "equal") (map maple2AST es) @@ -546,6 +552,8 @@   [ InertName "Add"   , InertArgs ExpSeq [e1]]) = R_Add (maple2AST e1) +maple2ReducerAST _ = error "TODO: maple2ReducerAST, so many cases..."+ mapleDatum2AST :: Text -> InertExpr -> AST' Text mapleDatum2AST h d = case (h, maple2DCode d) of   ("pair", [x,y]) -> Pair x y@@ -651,6 +659,7 @@         [InertName "Branch",          InertArgs ExpSeq [pat, e]]) =     Branch' (maple2Pattern pat) (maple2AST e)+branch _ = error "Branch: got some ill-formed case statement back?"   maple2Pattern :: InertExpr -> Pattern' Text

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-}-module Language.Hakaru.Parser.Parser where+module Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports) where  import Prelude hiding (Real) @@ -8,35 +8,37 @@ import           Data.Functor                  ((<$>), (<$)) import           Control.Applicative           (Applicative(..)) #endif-import qualified Control.Monad                 as M import           Data.Functor.Identity import           Data.Text                     (Text) import qualified Data.Text                     as Text import           Data.Ratio                    ((%)) import           Data.Char                     (digitToInt)-import           Text.Parsec                   hiding (Empty)+import           Text.Parsec import           Text.Parsec.Text              () -- instances only import           Text.Parsec.Indentation import           Text.Parsec.Indentation.Char import qualified Text.Parsec.Indentation.Token as ITok-import qualified Text.Parsec.Expr              as Ex+import           Text.Parsec.Expr              (Assoc(..), Operator(..)) import qualified Text.Parsec.Token             as Tok  import Language.Hakaru.Parser.AST-+import Language.Hakaru.Syntax.IClasses (Some2(..))+import Language.Hakaru.Syntax.AST (allTransforms, transformName) -ops, types, names :: [String]-ops   = ["+","*","-","^", "**", ":",".", "<~",-         "==", "=", "_", "<|>", "&&", "||"]-types = ["->"]-names = ["def", "fn", "if", "else", "∞", "expect", "observe",-         "return", "match", "integrate", "summate", "product",-         "data", "import"]+ops, names :: [String]+ops = words "^ ** * / + - .  < > <= >= == /= && || <|> -> : <~ = _"+names = concatMap words [ "def fn"+                        , "if else match"+                        , "return dirac"+                        , "integrate summate product from to"+                        , "array plate chain of"+                        , "r_nop r_split r_index r_fanout r_add bucket"+                        , "import data ∞" ] +++        map (\(Some2 t) -> transformName t) allTransforms  type ParserStream    = IndentStream (CharIndentStream Text) type Parser          = ParsecT     ParserStream () Identity-type Operator a      = Ex.Operator ParserStream () Identity a-type OperatorTable a = [[Operator a]]+type OperatorTable a = [[Operator ParserStream () Identity a]]  style :: Tok.GenLanguageDef ParserStream st Identity style = ITok.makeIndentLanguageDef $ Tok.LanguageDef@@ -45,22 +47,14 @@     , Tok.nestedComments  = True     , Tok.identStart      = letter <|> char '_'     , Tok.identLetter     = alphaNum <|> oneOf "_'"-    , Tok.opStart         = oneOf "!$%&*+./<=>?@\\^|-~"-    , Tok.opLetter        = oneOf "!$%&*+./<=>?@\\^|-~"+    , Tok.opStart         = oneOf [ c | c:_ <- ops ]+    , Tok.opLetter        = oneOf [ c | _:cs <- ops, c <- cs ]     , Tok.caseSensitive   = True     , Tok.commentLine     = "#"-    , Tok.reservedOpNames = ops ++ types+    , Tok.reservedOpNames = ops     , Tok.reservedNames   = names     } -comments :: Parser ()-comments = string "#"-           *> manyTill anyChar newline-           *> return ()--emptyLine :: Parser ()-emptyLine = newline *> return ()- lexer :: Tok.GenTokenParser ParserStream () Identity lexer = ITok.makeTokenParser style @@ -70,14 +64,9 @@ decimal :: Parser Integer decimal = Tok.decimal lexer -integer :: Parser Integer-integer = Tok.integer lexer--float :: Parser Rational-float =  (decimal >>= fractExponent) <* whiteSpace--fractFloat :: Integer -> Parser (Either Integer Rational)-fractFloat n  =  fractExponent n >>= return . Right+decimalFloat :: Parser Literal'+decimalFloat = do n <- decimal+                  option (Nat n) (Prob <$> fractExponent n)  fractExponent   :: Integer -> Parser Rational fractExponent n =  do{ fract <- fraction@@ -90,181 +79,187 @@                     }  fraction        :: Parser Rational-fraction        =  do{ _ <- char '.'-                     ; digits <- many1 digit <?> "fraction"-                     ; return (foldr op 0 digits)+fraction        =  do{ d      <- try (char '.' *> digit)+                     ; digits <- many digit <?> "fraction"+                     ; return (foldr1 op (map (fromIntegral.digitToInt) (d:digits))+                               / 10)                      }                   <?> "fraction"                     where-                      op d f    = (f + fromIntegral (digitToInt d))/10+                      op d f    = d + f / 10  exponent'       :: Parser Rational exponent'       =  do{ _ <- oneOf "eE"-                     ; f <- sign+                     ; f <- (negate <$ char '-') <|> (id <$ optional (char '+'))                      ; e <- decimal <?> "exponent"-                     ; return (power (f e))+                     ; return (10 ^^ f e)                      }                   <?> "exponent"-                      where-                       power e  | e < 0      = 1.0/power(-e)-                                | otherwise  = fromInteger (10^e)-                       sign            =   (char '-' >> return negate)-                                       <|> (char '+' >> return id)-                                       <|> return id  parens :: Parser a -> Parser a parens = Tok.parens lexer . localIndentation Any -braces :: Parser a -> Parser a-braces = Tok.parens lexer . localIndentation Any- brackets :: Parser a -> Parser a brackets = Tok.brackets lexer . localIndentation Any  commaSep :: Parser a -> Parser [a] commaSep = Tok.commaSep lexer -semiSep :: Parser a -> Parser [a]-semiSep = Tok.semiSep lexer--semiSep1 :: Parser a -> Parser [a]-semiSep1 = Tok.semiSep1 lexer- identifier :: Parser Text-identifier = M.liftM Text.pack $ Tok.identifier lexer+identifier = Text.pack <$> Tok.identifier lexer  reserved :: String -> Parser ()-reserved = Tok.reserved lexer+reserved s+  | s `elem` names -- assertion+  = Tok.reserved lexer s+  | otherwise+  = error ("Parser failed to reserve the name " ++ show s)  reservedOp :: String -> Parser ()-reservedOp = Tok.reservedOp lexer--symbol :: Text -> Parser Text-symbol = M.liftM Text.pack . Tok.symbol lexer . Text.unpack+reservedOp s+  | s `elem` ops -- assertion+  = Tok.reservedOp lexer s+  | otherwise+  = error ("Parser failed to reserve the operator " ++ show s) -app1 :: Text -> AST' Text -> AST' Text-app1 s x@(WithMeta _ m) = WithMeta (Var s `App` x) m-app1 s x                = Var s `App` x+app1 :: a -> AST' a -> AST' a+app1 s x = Var s `App` x -app2 :: Text -> AST' Text -> AST' Text -> AST' Text+app2 :: a -> AST' a -> AST' a -> AST' a app2 s x y = Var s `App` x `App` y --- | Smart constructor for divide-divide :: AST' Text -> AST' Text -> AST' Text-divide (ULiteral x') (ULiteral y') = ULiteral (go x' y')-  where go :: Literal' -> Literal' -> Literal'-        go (Nat  x) (Nat  y) = Prob (x % y)-        go x        y        = Real (litToRat x / litToRat y)--        litToRat :: Literal' -> Rational-        litToRat (Nat  x) = toRational x-        litToRat (Int  x) = toRational x-        litToRat (Prob x) = toRational x-        litToRat (Real x) = toRational x+divide, sub :: AST' Text -> AST' Text -> AST' Text+divide       (WithMeta (ULiteral (Nat   x     )) (SourceSpan s _))+             (WithMeta (ULiteral (Nat       y )) (SourceSpan _ e))+           = (WithMeta (ULiteral (Prob (x % y))) (SourceSpan s e))+divide       (WithMeta (ULiteral (Nat   1     )) (SourceSpan _ _))+             y+           = app1 "recip" y divide x y = NaryOp Prod [x, app1 "recip" y]+sub    x y = NaryOp Sum  [x, app1 "negate" y] -binop :: Text ->  AST' Text ->  AST' Text ->  AST' Text-binop s x y-    | s == "+"   = NaryOp Sum  [x, y]-    | s == "-"   = NaryOp Sum  [x, app1 "negate" y]-    | s == "*"   = NaryOp Prod [x, y]-    | s == "/"   = x `divide` y-    | s == "<"   = app2 "less"  x y-    | s == ">"   = app2 "less"  y x-    | s == "=="  = app2 "equal" x y-    | s == "<="  = NaryOp Or [ app2 "less"  x y-                             , app2 "equal" x y]-    | s == ">="  = NaryOp Or [ app2 "less"  y x-                             , app2 "equal" x y]-    | s == "&&"  = NaryOp And  [x, y]-    | s == "||"  = NaryOp Or   [x, y]-    | s == "<|>" = Msum [x, y]-    | otherwise  = app2 s x y+bi :: ([a] -> b) -> a -> a -> b+bi f x y = f [x, y] -binary :: String -> Ex.Assoc -> Operator (AST' Text)-binary s = Ex.Infix (binop (Text.pack s) <$ reservedOp s)+negate_rel :: (AST' Text -> AST' Text -> AST' Text)+           -> (AST' Text -> AST' Text -> AST' Text)+negate_rel f x y = app1 "not" (f x y) -prefix :: String -> (a -> a) -> Operator a-prefix s f = Ex.Prefix (f <$ reservedOp s)+binary :: String+       -> Assoc+       -> (a -> a -> a)+       -> Operator ParserStream () Identity a+binary s a f = Infix (f <$ reservedOp s) a -postfix :: Parser (a -> a) -> Operator a-postfix p = Ex.Postfix . chainl1 p . return $ flip (.)+postfix :: Stream s m t+        => ParsecT s u m (AST' a -> AST' a)+        -> Operator s u m (AST' a)+postfix p = Postfix (chainl1 p' (return (flip (.))))+  where p' = do f <- p+                e <- getPosition+                return (\x -> case x of+                  WithMeta _ (SourceSpan s _) -> WithMeta (f x) (SourceSpan s e)+                  _                           ->           f x) +sign :: Parser (AST' Text -> AST' Text)+sign = do+  s <- getPosition+  (fNat, fProb, fRest)+    <- ((id    , id    , id           ) <$ reservedOp "+") <|>+       ((negate, negate, app1 "negate") <$ reservedOp "-")+  let f     (WithMeta (ULiteral (Nat         x )) (SourceSpan _ e))+          = (WithMeta (ULiteral (Int  (fNat  x))) (SourceSpan s e))+      f     (WithMeta (ULiteral (Prob        x )) (SourceSpan _ e))+          = (WithMeta (ULiteral (Real (fProb x))) (SourceSpan s e))+      f x = fRest x+  return f+ table :: OperatorTable (AST' Text)-table =-    [ [ postfix array_index ]-    , [ prefix "+"  id ]-    , [ binary "^"  Ex.AssocRight-      , binary "**" Ex.AssocRight]-    , [ binary "*"  Ex.AssocLeft-      , binary "/"  Ex.AssocLeft]-    , [ binary "+"  Ex.AssocLeft-      , binary "-"  Ex.AssocLeft-      , prefix "-"  (app1 "negate")]-    -- TODO: add "/="-    -- TODO: do you *really* mean AssocLeft? Shouldn't they be non-assoc?-    , [ postfix ann_expr ]-    , [ binary "<|>" Ex.AssocRight]-    , [ binary "<"   Ex.AssocLeft-      , binary ">"   Ex.AssocLeft-      , binary "<="  Ex.AssocLeft-      , binary ">="  Ex.AssocLeft-      , binary "=="  Ex.AssocLeft]-    , [ binary "&&"  Ex.AssocLeft]-    , [ binary "||"  Ex.AssocLeft]]+table = [ [ postfix (array_index <|> fun_call) ]+        , [ binary "^"   AssocRight $ app2 "^"+          , binary "**"  AssocRight $ app2 "**" ]+        , [ binary "*"   AssocLeft  $ bi (NaryOp Prod)+          , binary "/"   AssocLeft  $ divide ]+        , [ Prefix sign+          , binary "+"   AssocLeft  $ bi (NaryOp Sum)+          , binary "-"   AssocLeft  $ sub ]+        , [ postfix ann_expr ]+        , [ binary "<"   AssocNone  $                     app2 "less"+          , binary ">"   AssocNone  $              flip $ app2 "less"+          , binary "<="  AssocNone  $ negate_rel $ flip $ app2 "less"+          , binary ">="  AssocNone  $ negate_rel $        app2 "less"+          , binary "=="  AssocNone  $                     app2 "equal"+          , binary "/="  AssocNone  $ negate_rel $        app2 "equal" ]+        , [ binary "&&"  AssocRight $ bi (NaryOp And) ]+        , [ binary "||"  AssocRight $ bi (NaryOp Or) ]+        , [ binary "<|>" AssocRight $ bi Msum ] ] -unit_ :: Parser (AST' a)-unit_ = Unit <$ symbol "()"+red_expr :: Parser (Reducer' Text)+red_expr =  red_fanout+        <|> red_index+        <|> red_split+        <|> red_nop+        <|> red_add -empty_ :: Parser (AST' a)-empty_ = Empty <$ symbol "[]"+red_fanout :: Parser (Reducer' Text)+red_fanout = reserved "r_fanout" *>+             (R_Fanout+              <$> red_expr+              <*  reservedOp "||"+              <*> red_expr+              ) -int :: Parser (AST' a)-int = do-    n <- integer-    return $-        if n < 0-        then ULiteral $ Int n-        else ULiteral $ Nat n+red_split :: Parser (Reducer' Text)+red_split = reserved "r_split" *>+             (R_Split+              <$> expr+              <*  reservedOp ":"+              <*> red_expr+              <*  reserved "else"+              <*  reservedOp ":"+              <*> red_expr+              ) -floating :: Parser (AST' a)-floating = do-    sign <- option '+' (oneOf "+-")-    n <- float-    return $-        case sign of-        '-' -> ULiteral $ Real (negate n)-        '+' -> ULiteral $ Prob n-        _   -> error "floating: the impossible happened"+red_index :: Parser (Reducer' Text)+red_index = reserved "r_index" *>+             (R_Index+              <$> identifier+              <*  reservedOp "="+              <*> expr+              <*  reserved "of"+              <*> expr+              <*  reservedOp ":"+              <*> red_expr+              ) -inf_ :: Parser (AST' Text)+red_nop :: Parser (Reducer' Text)+red_nop = reserved "r_nop" *> return R_Nop++red_add :: Parser (Reducer' Text)+red_add = reserved "r_add" *> (R_Add <$> expr)+++natOrProb :: Parser (AST' a)+natOrProb = (ULiteral <$> decimalFloat) <* whiteSpace++inf_ :: Parser (AST' a) inf_ = reserved "∞" *> return Infinity'  var :: Parser (AST' Text) var = Var <$> identifier -pairs :: Parser (AST' Text)-pairs = foldr1 Pair <$> parens (commaSep expr)--type_var :: Parser TypeAST'-type_var = TypeVar <$> identifier--type_app :: Parser TypeAST'-type_app = TypeApp <$> identifier <*> parens (commaSep type_expr)+parenthesized :: Parser (AST' Text)+parenthesized = f <$> parens (commaSep expr)+  where f [] = Unit+        f xs = foldr1 Pair xs -type_fun :: Parser TypeAST'-type_fun =-    chainr1-        (    try type_app-         <|> try type_var-         <|> parens type_fun)-        (TypeFun <$ reservedOp "->")+type_var_or_app :: Parser TypeAST'+type_var_or_app = do x <- ("array" <$ reserved "array") <|> identifier+                     option (TypeVar x) (TypeApp x <$> parens (commaSep type_expr))  type_expr :: Parser TypeAST'-type_expr = try type_fun-        <|> try type_app-        <|> try type_var-        <|> parens type_expr+type_expr = foldr1 TypeFun <$> sepBy1 (parens type_expr <|> type_var_or_app)+                                      (reservedOp "->")  ann_expr :: Parser (AST' Text -> AST' Text) ann_expr = reservedOp "." *> (flip Ann <$> type_expr)@@ -275,8 +270,8 @@ pat_expr :: Parser (Pattern' Text) pat_expr =  try (PData' <$> pdat_expr)         <|> (PData' <$> (DV "pair" <$> parens (commaSep pat_expr)))-        <|> (PWild' <$ reservedOp "_")-        <|> (PVar' <$> identifier)+        <|> (PWild' <$  reservedOp "_")+        <|> (PVar'  <$> identifier)   -- | Blocks are indicated by colons, and must be indented.@@ -286,42 +281,25 @@     localIndentation Gt (many $ absoluteIndentation p)  --- | Semiblocks are like blocks, but indentation is optional. Also,--- there are only 'expr' semiblocks.-semiblockExpr :: Parser (AST' Text)-semiblockExpr = reservedOp ":" *> localIndentation Ge expr----- | Pseudoblocks seem like semiblocks, but actually they aren't--- indented.------ TODO: do we actually want this in our grammar, or did we really--- mean to use 'semiblockExpr' instead?-pseudoblockExpr :: Parser (AST' Text)-pseudoblockExpr = reservedOp ":" *> expr-- branch_expr :: Parser (Branch' Text)-branch_expr = Branch' <$> pat_expr <*> semiblockExpr+branch_expr = Branch' <$> pat_expr <* reservedOp ":"+              <*> localIndentation Gt expr  match_expr :: Parser (AST' Text)-match_expr =-    reserved "match"-    *>  (Case-        <$> expr-        <*> blockOfMany branch_expr-        )+match_expr = Case <$ reserved "match" <*> expr <* reservedOp ":"+             <*> localIndentation Ge (many (absoluteIndentation branch_expr))  integrate_expr :: Parser (AST' Text) integrate_expr =     reserved "integrate"     *> (Integrate         <$> identifier-        <*  symbol "from"+        <*  reserved "from"         <*> expr-        <*  symbol "to"+        <*  reserved "to"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )  summate_expr :: Parser (AST' Text)@@ -329,11 +307,12 @@     reserved "summate"     *> (Summate         <$> identifier-        <*  symbol "from"+        <*  reserved "from"         <*> expr-        <*  symbol "to"+        <*  reserved "to"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )  product_expr :: Parser (AST' Text)@@ -341,28 +320,55 @@     reserved "product"     *> (Product         <$> identifier-        <*  symbol "from"+        <*  reserved "from"         <*> expr-        <*  symbol "to"+        <*  reserved "to"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         ) -expect_expr :: Parser (AST' Text)-expect_expr =-    reserved "expect"-    *> (Expect+transform_expr :: Parser (AST' Text)+transform_expr = expect_expr <|> tr+  where+     trNm :: Parser Transform'+     trNm = choice $+       map (\(Some2 t) -> reserved (transformName t)+                       *> pure (trFromTyped t))+           allTransforms++     sarg :: Parser ([Text], AST' Text)+     sarg = (,)+       <$> option [] (try (many1 identifier <* reservedOp ":"))+       <*> expr++     tr :: Parser (AST' Text)+     tr =  Transform+       <$> trNm+       <*> (SArgs' <$> parens (commaSep sarg))++     expect_expr :: Parser (AST' Text)+     expect_expr =+         reserved "expect"+         *> (_Expect+             <$> identifier+             <*  reservedOp "<~"+             <*> expr+             <*  reservedOp ":"+             <*> expr+             )++bucket_expr :: Parser (AST' Text)+bucket_expr =+    reserved "bucket"+    *> (Bucket         <$> identifier+        <*  reserved "from"         <*> expr-        <*> semiblockExpr-        )--observe_expr :: Parser (AST' Text)-observe_expr =-    reserved "observe"-    *> (Observe-        <$> expr+        <*  reserved "to"         <*> expr+        <*  reservedOp ":"+        <*> red_expr         )  array_expr :: Parser (AST' Text)@@ -370,49 +376,46 @@     reserved "array"     *> (Array         <$> identifier-        <*  symbol "of"+        <*  reserved "of"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )  array_index :: Parser (AST' Text -> AST' Text) array_index = flip Index <$> brackets expr  array_literal :: Parser (AST' Text)-array_literal = checkEmpty <$> brackets (commaSep expr)-  where checkEmpty [] = Empty-        checkEmpty xs = ArrayLiteral xs+array_literal = ArrayLiteral <$> brackets (commaSep expr)  plate_expr :: Parser (AST' Text) plate_expr =     reserved "plate"     *> (Plate         <$> identifier-        <*  symbol "of"+        <*  reserved "of"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )  chain_expr :: Parser (AST' Text) chain_expr =     reserved "chain"-    *> (Chain+    *> (flip . Chain         <$> identifier+        <*  reserved "from"         <*> expr+        <*  reserved "of"         <*> expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )   if_expr :: Parser (AST' Text)-if_expr =-    reserved "if"-    *>  (If-        <$> localIndentation Ge expr-        <*> semiblockExpr-        <*  reserved "else"-        <*> semiblockExpr-        )+if_expr = If <$ reserved "if" <*> expr <* reservedOp ":" <*> expr+             <* reserved "else"        <* reservedOp ":" <*> expr  lam_expr :: Parser (AST' Text) lam_expr =@@ -420,80 +423,73 @@     *>  (Lam         <$> identifier         <*> type_expr-        <*> semiblockExpr+        <*  reservedOp ":"+        <*> expr         )  bind_expr :: Parser (AST' Text)-bind_expr = Bind-    <$> identifier-    <*  reservedOp "<~"-    <*> expr-    <*> expr+bind_expr = localIndentation Ge+  (absoluteIndentation (try (Bind <$> identifier <* reservedOp "<~")+   <*> localIndentation Gt expr)+   <*> absoluteIndentation expr)  let_expr :: Parser (AST' Text)-let_expr = Let-    <$> identifier-    <*  reservedOp "="-    <*> expr-    <*> expr+let_expr = localIndentation Ge+  (absoluteIndentation (try (Let <$> identifier <* reservedOp "=")+   <*> localIndentation Gt expr)+   <*> absoluteIndentation expr)  def_expr :: Parser (AST' Text)-def_expr = do-    reserved "def"+def_expr = localIndentation Ge $ do+    absoluteIndentation (reserved "def")     name <- identifier     vars <- parens (commaSep defarg)     bodyTyp <- optionMaybe type_expr-    body    <- semiblockExpr+    reservedOp ":"+    body    <- localIndentation Gt expr     let body' = foldr (\(var', varTyp) e -> Lam var' varTyp e) body vars         typ   = foldr TypeFun <$> bodyTyp <*> return (map snd vars)     Let name (maybe id (flip Ann) typ body')-        <$> expr -- the \"rest\"; i.e., where the 'def' is in scope+        <$> absoluteIndentation expr -- the \"rest\"; i.e., where the 'def' is in scope  defarg :: Parser (Text, TypeAST') defarg = (,) <$> identifier <*> type_expr -call_expr :: Parser (AST' Text)-call_expr =-    foldl App-        <$> (Var <$> identifier)-        <*> parens (commaSep expr)+fun_call :: Parser (AST' Text -> AST' Text)+fun_call = flip (foldl App) <$> parens (commaSep expr)  return_expr :: Parser (AST' Text) return_expr = do     reserved "return" <|> reserved "dirac"-    Dirac <$> expr+    app1 "dirac" <$> expr  term :: Parser (AST' Text)-term =  try if_expr-    <|> try return_expr-    <|> try lam_expr-    <|> try def_expr-    <|> try match_expr-    <|> try data_expr-    <|> try integrate_expr-    <|> try summate_expr-    <|> try product_expr-    <|> try expect_expr-    <|> try observe_expr-    <|> try array_expr-    <|> try plate_expr-    <|> try chain_expr-    <|> try let_expr-    <|> try bind_expr-    <|> try call_expr-    <|> try array_literal-    <|> try floating-    <|> try inf_-    <|> try unit_-    <|> try empty_-    <|> try int-    <|> try var-    <|> try pairs-    <|> parens expr-    <?> "an expression"+term =  if_expr+    <|> lam_expr+    <|> def_expr+    <|> match_expr+    <|> data_expr+    <|> integrate_expr+    <|> summate_expr+    <|> product_expr+    <|> transform_expr+    <|> bucket_expr+    <|> array_expr+    <|> plate_expr+    <|> chain_expr+    <|> array_literal+    <|> inf_+    <|> natOrProb+    <|> var+    <|> parenthesized+    <?> "simple expression"  expr :: Parser (AST' Text)-expr = withPos (Ex.buildExpressionParser table (withPos term) <?> "an expression")+expr = withPos (let_expr <|>+                bind_expr <|>+                return_expr <|>+                buildExpressionParser table (withPos term))+       <?> "expression"   indentConfig :: Text -> ParserStream@@ -506,10 +502,10 @@ parseHakaruWithImports :: Text -> Either ParseError (ASTWithImport' Text) parseHakaruWithImports = parseAtTopLevel exprWithImport -parseAtTopLevel :: Parser a -> Text -> Either ParseError a -parseAtTopLevel p = -    runParser (skipMany (comments <|> emptyLine) *>-               p <* eof) () "<input>" . indentConfig . Text.strip +parseAtTopLevel :: Parser a -> Text -> Either ParseError a+parseAtTopLevel p =+    runParser (whiteSpace *>+               p <* eof) () "<input>" . indentConfig  withPos :: Parser (AST' a) -> Parser (AST' a) withPos x = do@@ -535,7 +531,7 @@     reserved "data"     ident <- identifier     typvars <- parens (commaSep identifier)-    ts <- blockOfMany (try type_app <|> type_var)+    ts <- blockOfMany type_var_or_app     e <- expr     return (Data ident typvars ts e) @@ -545,3 +541,98 @@  exprWithImport :: Parser (ASTWithImport' Text) exprWithImport = ASTWithImport' <$> (many import_expr) <*> expr++-- | A variant of @Text.Parsec.Expr.buildExpressionParser@ (parsec-3.1.11)+-- that behaves more restrictively when a precedence level contains both+-- unary and binary operators.  Unary operators are only allowed on the+-- first operand when parsing left-associatively and on the last operand+-- when parsing right-associatively.  This restriction lets us recover the+-- behavior of unary negation in Haskell.++buildExpressionParser :: (Stream s m t)+                      => [[Operator s u m a]]+                      -> ParsecT s u m a+                      -> ParsecT s u m a+buildExpressionParser operators simpleExpr+    = foldl (makeParser) simpleExpr operators+    where+      makeParser term' ops'+        = let (rassoc,lassoc,nassoc+               ,prefix,postfix')      = foldr splitOp ([],[],[],[],[]) ops'++              rassocOp   = choice rassoc+              lassocOp   = choice lassoc+              nassocOp   = choice nassoc+              prefixOp   = choice prefix  <?> ""+              postfixOp  = choice postfix' <?> ""++              ambigious assoc op= try $+                                  do{ _ <- op+                                    ; fail ("ambiguous use of a " ++ assoc+                                            ++ " associative operator")+                                    }++              ambigiousRight    = ambigious "right" rassocOp+              ambigiousLeft     = ambigious "left" lassocOp+              ambigiousNon      = ambigious "non" nassocOp++              termP      = do{ (preU, pre)   <- prefixP+                             ; x             <- term'+                             ; (postU, post) <- postfixP+                             ; return (preU || postU, post (pre x))+                             }++              postfixP   = ((,) True) <$> postfixOp <|> return (False, id)++              prefixP    = ((,) True) <$> prefixOp <|> return (False, id)++              rassocP x  = do{ f      <- rassocOp+                             ; (u, z) <- termP+                             ; y      <- if u then return z else rassocP1 z+                             ; return (f x y)+                             }+                           <|> ambigiousLeft+                           <|> ambigiousNon+                           -- <|> return x++              rassocP1 x = rassocP x  <|> return x++              lassocP x  = do{ f <- lassocOp+                             ; y <- term'+                             ; lassocP1 (f x y)+                             }+                           <|> ambigiousRight+                           <|> ambigiousNon+                           -- <|> return x++              lassocP1 x = lassocP x <|> return x++              nassocP x  = do{ f <- nassocOp+                             ; y <- term'+                             ;    ambigiousRight+                              <|> ambigiousLeft+                              <|> ambigiousNon+                              <|> return (f x y)+                             }+                           -- <|> return x++           in  do{ (u, x) <- termP+                 ;     (if u then parserZero else rassocP x)+                   <|>                            lassocP x+                   <|> (if u then parserZero else nassocP x)+                   <|>                            return  x+                   <?> "operator"+                 }+++      splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix')+        = case assoc of+            AssocNone  -> (rassoc,lassoc,op:nassoc,prefix,postfix')+            AssocLeft  -> (rassoc,op:lassoc,nassoc,prefix,postfix')+            AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix')++      splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix')+        = (rassoc,lassoc,nassoc,op:prefix,postfix')++      splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix')+        = (rassoc,lassoc,nassoc,prefix,op:postfix')

@@ -3,9 +3,15 @@            , DataKinds            , KindSignatures            , GADTs+           , LambdaCase+           , PolyKinds+           , RankNTypes            #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-}-module Language.Hakaru.Parser.SymbolResolve where+module Language.Hakaru.Parser.SymbolResolve+    (+      resolveAST, resolveAST', makeName, fromVarSet+    ) where  import Data.Text hiding (concat, map, maximum, foldr1, singleton) #if __GLASGOW_HASKELL__ < 710@@ -13,6 +19,7 @@ import Control.Applicative              ((<*>)) #endif import Control.Monad.Trans.State.Strict (State, state, evalState)+import Control.Monad (join)  import qualified Data.Number.Nat                 as N import qualified Data.IntMap                     as IM@@ -25,11 +32,12 @@ import           Language.Hakaru.Types.DataKind  hiding (Symbol) import           Language.Hakaru.Types.HClasses import qualified Language.Hakaru.Syntax.AST      as T-import           Language.Hakaru.Syntax.ABT+import           Language.Hakaru.Syntax.ABT      hiding (fromVarSet) import           Language.Hakaru.Syntax.IClasses import           Language.Hakaru.Syntax.Variable () import qualified Language.Hakaru.Parser.AST   as U import           Language.Hakaru.Evaluation.Coalesce (coalesce)+import qualified Language.Hakaru.Syntax.Prelude  as P  data Symbol a     = TLam (a -> Symbol a)@@ -99,15 +107,15 @@     ,("true",        TNeu $ true_)     ,("false",       TNeu $ false_)      -- Coercions-    ,("int2nat",     primUnsafe cNat2Int)+    ,("int2nat",     primUnsafe cNat2Int)  -- unsafe, wrong direction     ,("int2real",    primCoerce cInt2Real)     ,("prob2real",   primCoerce cProb2Real)-    ,("real2prob",   primUnsafe cProb2Real)+    ,("real2prob",   primUnsafe cProb2Real) -- unsafe, wrong direction     ,("nat2real",    primCoerce cNat2Real)     ,("nat2prob",    primCoerce cNat2Prob)     ,("nat2int",     primCoerce cNat2Int)      -- Measures-    ,("lebesgue",    TNeu $ syn $ U.MeasureOp_ (U.SomeOp T.Lebesgue) [])+    ,("lebesgue",    primMeasure2 (U.SomeOp T.Lebesgue))     ,("counting",    TNeu $ syn $ U.MeasureOp_ (U.SomeOp T.Counting) [])     ,("uniform",     primMeasure2 (U.SomeOp T.Uniform))     ,("normal",      primMeasure2 (U.SomeOp T.Normal))@@ -121,8 +129,13 @@     ,("reject",      TNeu $ syn U.Reject_)     -- PrimOps     ,("not",         primPrimOp1 U.Not)+    ,("impl",        primPrimOp2 U.Impl)+    ,("diff",        primPrimOp2 U.Diff)+    ,("nand",        primPrimOp2 U.Nand)+    ,("nor",         primPrimOp2 U.Nor)     ,("pi",          primPrimOp0 U.Pi)     ,("**",          primPrimOp2 U.RealPow)+    ,("choose",      primPrimOp2 U.Choose)     ,("cos",         primPrimOp1 U.Cos)     ,("exp",         primPrimOp1 U.Exp)     ,("log",         primPrimOp1 U.Log)@@ -151,12 +164,19 @@     ,("asinh",       primPrimOp1 U.Asinh)     ,("acosh",       primPrimOp1 U.Acosh)     ,("atanh",       primPrimOp1 U.Atanh)+    ,("floor",       primPrimOp1 U.Floor)     -- ArrayOps     ,("size",        TLam $ \x -> TNeu . syn $ U.ArrayOp_ U.Size [x])     ,("reduce",      t3 $ \x y z -> syn $ U.ArrayOp_ U.Reduce [x, y, z])     -- NaryOps+    ,("xor",         t2 $ \x y -> syn $ U.NaryOp_ U.Xor [x, y])+    ,("iff",         t2 $ \x y -> syn $ U.NaryOp_ U.Iff [x, y])     ,("min",         t2 $ \x y -> syn $ U.NaryOp_ U.Min [x, y])     ,("max",         t2 $ \x y -> syn $ U.NaryOp_ U.Max [x, y])++    -- Macros+    ,("weibull",     TNeu $ syn $ U.InjTyped $+                     P.lam $ \x -> P.lam $ \y -> P.weibull x y)     ]  primPrimOp0, primPrimOp1, primPrimOp2 :: U.PrimOp -> Symbol U.AST@@ -262,6 +282,19 @@         <$> symbolResolution symbols e1         <*> symbolResolution (insertSymbol name' symbols) e2 +resolveTransform+    :: SymbolTable+    -> U.Transform'+    -> U.SArgs' Text+    -> State Int (U.AST' (Symbol U.AST))+resolveTransform symbols tr (U.SArgs' es) =+    U.Transform tr . U.SArgs' <$> mapM go es where+      go :: ([Text], U.AST' Text)+         -> State Int ([Symbol U.AST], U.AST' (Symbol U.AST))+      go (nms,x) = do+        nms' <- mapM gensym nms+        (,) (map mkSym nms') <$>+            symbolResolution (insertSymbols nms' symbols) x  -- TODO: clean up by merging the @Reader (SymbolTable)@ and @State Int@ monads -- | Figure out symbols and types.@@ -327,7 +360,6 @@         <$> mapM (symbolResolution symbols) es      U.Unit              -> return $ U.Unit-    U.Empty             -> return $ U.Empty     U.Pair e1 e2        -> U.Pair         <$> symbolResolution symbols e1         <*> symbolResolution symbols e2@@ -344,19 +376,15 @@         <$> symbolResolution symbols e1         <*> mapM (symbolResolveBranch symbols) bs -    U.Dirac  e1            -> U.Dirac <$> symbolResolution symbols e1     U.Bind   name e1 e2    -> resolveBinder symbols name e1 e2 U.Bind     U.Plate  name e1 e2    -> resolveBinder symbols name e1 e2 U.Plate-    U.Expect name e1 e2    -> resolveBinder symbols name e1 e2 U.Expect+    U.Transform tr es      -> resolveTransform symbols tr es     U.Chain  name e1 e2 e3 -> do         name' <- gensym name         U.Chain (mkSym name')             <$> symbolResolution symbols e1             <*> symbolResolution symbols e2             <*> symbolResolution (insertSymbol name' symbols) e3-    U.Observe e1 e2        -> U.Observe-        <$> symbolResolution symbols e1-        <*> symbolResolution symbols e2      U.Msum es -> U.Msum <$> mapM (symbolResolution symbols) es @@ -432,10 +460,11 @@     U.Var a           -> U.Var a     U.Lam name typ f  -> U.Lam name typ (normAST f)     U.App f x ->-        let x' = normAST x in-        case normAST f of+        let x' = normAST x+            f' = normAST f in+        case U.withoutMeta f' of         U.Var (TLam f)      -> U.Var $ f (makeAST x')-        f'                  -> U.App f' x'+        _                   -> U.App f' x'      U.Let name e1 e2          -> U.Let name (normAST e1) (normAST e2)     U.If e1 e2 e3             -> U.If (normAST e1) (normAST e2) (normAST e3)@@ -448,23 +477,23 @@     U.ULiteral v              -> U.ULiteral v     U.NaryOp op es            -> U.NaryOp op (map normAST es)     U.Unit                    -> U.Unit-    U.Empty                   -> U.Empty     U.Pair e1 e2              -> U.Pair (normAST e1) (normAST e2)     U.Array  name e1 e2       -> U.Array name (normAST e1) (normAST e2)     U.ArrayLiteral   es       -> U.ArrayLiteral (map normAST es)     U.Index       e1 e2       -> U.Index (normAST e1) (normAST e2)     U.Case        e1 e2       -> U.Case  (normAST e1) (map branchNorm e2)-    U.Dirac       e1          -> U.Dirac (normAST e1)     U.Bind   name e1 e2       -> U.Bind   name (normAST e1) (normAST e2)     U.Plate  name e1 e2       -> U.Plate  name (normAST e1) (normAST e2)     U.Chain  name e1 e2 e3    -> U.Chain  name (normAST e1) (normAST e2) (normAST e3)-    U.Expect name e1 e2       -> U.Expect name (normAST e1) (normAST e2)-    U.Observe     e1 e2       -> U.Observe (normAST e1) (normAST e2)+    U.Transform tr es         -> U.Transform tr (normSArgs es)     U.Msum es                 -> U.Msum (map normAST es)     U.Data name tvars typs e  -> U.Data name tvars typs e      -- do we need to norm here? what if we try to define `true` which is already a constructor     U.WithMeta a meta         -> U.WithMeta (normAST a) meta +normSArgs :: U.SArgs' (Symbol U.AST) -> U.SArgs' (Symbol U.AST)+normSArgs (U.SArgs' es) = U.SArgs' $ map (fmap normAST) es+ branchNorm :: U.Branch' (Symbol U.AST) -> U.Branch' (Symbol U.AST) branchNorm (U.Branch'  pat e2') = U.Branch'  pat (normAST e2') branchNorm (U.Branch'' pat e2') = U.Branch'' pat (normAST e2')@@ -576,7 +605,6 @@     U.ULiteral v      -> syn $ U.Literal_  (U.val v)     U.NaryOp op es    -> syn $ U.NaryOp_ op (map makeAST es)     U.Unit            -> unit_-    U.Empty           -> syn $ U.Empty_     U.Pair e1 e2      -> syn $ U.Pair_ (makeAST e1) (makeAST e2)     U.Array s e1 e2 ->         withName "U.Array" s $ \name ->@@ -584,7 +612,6 @@     U.ArrayLiteral es -> syn $ U.ArrayLiteral_ (map makeAST es)     U.Index e1 e2     -> syn $ U.ArrayOp_ U.Index_ [(makeAST e1), (makeAST e2)]     U.Case e bs       -> syn $ U.Case_ (makeAST e) (map makeBranch bs)-    U.Dirac e1        -> syn $ U.Dirac_ (makeAST e1)     U.Bind s e1 e2 ->         withName "U.Bind" s $ \name ->             syn $ U.MBind_ (makeAST e1) (bind name $ makeAST e2)@@ -606,15 +633,74 @@     U.Bucket s e1 e2 e3 ->         withName "U.Bucket"  s $ \name ->             syn $ U.Bucket_ (makeAST e1) (makeAST e2) (makeReducerAST name e3 Nil1)-    U.Expect s e1 e2 ->-        withName "U.Expect" s $ \name ->-            syn $ U.Expect_ (makeAST e1) (bind name $ makeAST e2)-    U.Observe e1 e2  -> syn $ U.Observe_ (makeAST e1) (makeAST e2)+    U.Transform tr es -> makeTransform tr es     U.Msum es -> collapseSuperposes (map makeAST es)-     U.Data name tvars typs e -> error "TODO: makeAST{U.Data}"      U.WithMeta a meta -> withMetadata meta (makeAST a) +makeTransform :: U.Transform' -> U.SArgs' (Symbol U.AST) -> U.AST+makeTransform tru esu =+  case typedTransform tru of+    Some2 tr ->+      let wrongArgsErr = error $ "Wrong number of arguments passed to " +++                                 T.transformName tr+          res = U.Transform_ tr <$> matchSArgs (transformArgs tr) esu+      in maybe wrongArgsErr syn res++type SVarsSpine = (List1 (Lift1 ()) :: [k] -> *)+type SArgsSpine = (List1 (PointwiseP SVarsSpine (Lift1 ())) :: [([k],k1)] -> *)++transformArgs :: T.Transform xs a -> SArgsSpine xs+transformArgs t =+  let arg0 = PwP Nil1 (Lift1 ())+      arg1 = PwP (Cons1 (Lift1 ()) Nil1) (Lift1 ())+  in case t of+     -- TODO: can SingI be generalized to allow things which aren't `Sing's+     -- so these right hand sides can become `sing'?+       T.Observe   -> Cons1 arg0 $ Cons1 arg0 Nil1+       T.MH        -> Cons1 arg0 $ Cons1 arg0 Nil1+       T.MCMC      -> Cons1 arg0 $ Cons1 arg0 Nil1+       T.Disint k  -> Cons1 arg0 Nil1+       T.Summarize -> Cons1 arg0 Nil1+       T.Simplify  -> Cons1 arg0 Nil1+       T.Reparam   -> Cons1 arg0 Nil1+       T.Expect    -> Cons1 arg0 $ Cons1 arg1 Nil1++matchSArgs :: SArgsSpine xs -> U.SArgs' (Symbol U.AST)+           -> Maybe (U.SArgs U.U_ABT xs)+matchSArgs sp (U.SArgs' es) =+  case (sp, es) of+    ( Nil1, [] ) -> Just U.End+    ( Cons1 (PwP vs _) sp', (vs',e0):es' )+      -> join $ matchSVars vs vs' e0 $ \vsu e0' ->+           (U.:*) (vsu, e0') <$> matchSArgs sp' (U.SArgs' es')+    _ -> Nothing++matchSVars :: SVarsSpine vs -> [Symbol U.AST] -> U.AST' (Symbol U.AST)+           -> (forall vsu . List2 U.ToUntyped vs vsu+                         -> U.U_ABT vsu 'U.U+                         -> r)+           -> Maybe r+matchSVars vs nms e k =+  case (vs, nms) of+    (Nil1       , []     ) -> Just $ k Nil2 (makeAST e)+    (Cons1 v vs', nm:nms') ->+      matchSVars vs' nms' e $ \vsu e' ->+        withName "U.SArgs" nm $ \nm' ->+          k (Cons2 U.ToU vsu) (bind nm' e')+    _ -> Nothing++typedTransform :: U.Transform' -> Some2 T.Transform+typedTransform = \case+  U.Observe   -> Some2 T.Observe+  U.MH        -> Some2 T.MH+  U.MCMC      -> Some2 T.MCMC+  U.Disint k  -> Some2 $ T.Disint k+  U.Summarize -> Some2 T.Summarize+  U.Simplify  -> Some2 T.Simplify+  U.Reparam   -> Some2 T.Reparam+  U.Expect    -> Some2 T.Expect+ withName :: String -> Symbol U.AST -> (Variable 'U.U -> r) -> r withName fun s k =     case s of@@ -629,19 +715,20 @@     evalState (symbolResolution primTable ast) 0  resolveAST'-    :: [U.Name]+    :: N.Nat+    -> [U.Name]     -> U.AST' Text     -> U.AST-resolveAST' syms ast =+resolveAST' nextVar syms ast =     coalesce .     makeAST  .     normAST  $     evalState (symbolResolution         (insertSymbols syms primTable) ast)-        (nextVarID_ syms)+        (N.fromNat $ nextVarID_ syms)     where-    nextVarID_ [] = N.fromNat 0-    nextVarID_ xs = N.fromNat . (1+) . F.maximum $ map U.nameID xs+    nextVarID_ [] = nextVar+    nextVarID_ xs = max nextVar . (1+) . F.maximum $ map U.nameID xs  makeName :: SomeVariable ('KProxy :: KProxy Hakaru) -> U.Name makeName (SomeVariable (Variable hint vID _)) = U.Name vID hint

@@ -7,6 +7,7 @@            , TypeOperators            , FlexibleContexts            , UndecidableInstances+           , LambdaCase            #-}  {-# OPTIONS_GHC -Wall -fwarn-tabs #-}@@ -28,29 +29,34 @@       pretty     , prettyPrec     , prettyType-    , prettyAssoc-    , prettyPrecAssoc     , prettyValue+    , prettyT+    , prettyTypeT, prettyTypeS     -- * Helper functions (semi-public internal API)     ) where -import           System.Console.ANSI-import           Text.PrettyPrint                (Doc, (<>), (<+>))-import qualified Text.PrettyPrint                as PP-import qualified Data.Foldable                   as F-import qualified Data.List.NonEmpty              as L-import qualified Data.Text                       as Text+import           Prelude            hiding ((<>))+import           Text.PrettyPrint      (Doc, text, integer, double,+                                        (<+>), (<>), ($$), sep, cat, fsep, vcat,+                                        nest, parens, brackets, punctuate,+                                        comma, colon, equals)+import qualified Data.Foldable         as F+import qualified Data.List.NonEmpty    as L+import qualified Data.Text             as Text  -- Because older versions of "Data.Foldable" do not export 'null' apparently...-import qualified Data.Sequence                   as Seq-import qualified Data.Vector                     as V+import qualified Data.Sequence         as Seq+import qualified Data.Vector           as V import           Data.Ratio+import qualified Data.Text             as T+import           Control.Applicative   (Applicative(..)) -import           Data.Number.Natural  (fromNatural, fromNonNegativeRational)+import           Data.Number.Natural   (fromNatural, fromNonNegativeRational) import           Data.Number.Nat-import qualified Data.Number.LogFloat            as LF+import qualified Data.Number.LogFloat  as LF -import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, jmEq1, TypeEq(..))+import Language.Hakaru.Syntax.IClasses (fmap11, foldMap11, jmEq1, TypeEq(..)+                                       ,Foldable21(..)) import Language.Hakaru.Types.DataKind import Language.Hakaru.Types.Sing import Language.Hakaru.Types.Coercion@@ -58,230 +64,247 @@ import Language.Hakaru.Syntax.AST import Language.Hakaru.Syntax.Datum import Language.Hakaru.Syntax.Value+import Language.Hakaru.Syntax.Reducer import Language.Hakaru.Syntax.ABT-import Language.Hakaru.Pretty.Haskell-    (ppRatio, prettyAssoc, prettyPrecAssoc, Associativity(..))+import Language.Hakaru.Pretty.Haskell (Associativity(..))  ---------------------------------------------------------------- -- | Pretty-print a term. pretty :: (ABT Term abt) => abt '[] a -> Doc pretty = prettyPrec 0 +-- | Pretty print a term as a Text+prettyT :: (ABT Term abt) => abt '[] a -> T.Text+prettyT = T.pack . show . pretty +-- | Pretty-print a type as a Text+prettyTypeT :: Sing (a :: Hakaru) -> T.Text+prettyTypeT = T.pack . show . prettyType 0++-- | Pretty-print a type as a String+prettyTypeS :: Sing (a :: Hakaru) -> String+prettyTypeS = show . prettyType 0+ -- | Pretty-print a term at a given precendence level. prettyPrec :: (ABT Term abt) => Int -> abt '[] a -> Doc-prettyPrec p = toDoc . prettyPrec_ p . LC_+prettyPrec p = prettyPrec_ p . LC_  ---------------------------------------------------------------- class Pretty (f :: Hakaru -> *) where     -- | A polymorphic variant if 'prettyPrec', for internal use.-    prettyPrec_ :: Int -> f a -> Docs+    prettyPrec_ :: Int -> f a -> Doc -type Docs = [Doc] +mapInit :: (a -> a) -> [a] -> [a]+mapInit f (x:xs@(_:_)) = f x : mapInit f xs+mapInit _ xs           = xs --- So far as I can tell from the documentation, if the input is a singleton list then the result is the same as that singleton.-toDoc :: Docs -> Doc-toDoc = PP.cat+sepByR :: String -> [Doc] -> Doc+sepByR s = sep . mapInit (<+> text s) --- | Color a Doc-color :: Color -> Doc -> Doc-color c d =-    PP.text (setSGRCode [SetColor Foreground Dull c])-    <> d-    <> PP.text (setSGRCode [Reset])+sepComma :: [Doc] -> Doc+sepComma = fsep . punctuate comma+    -- It's safe to use fsep here despite our indentation-sensitive syntax,+    -- because commas are not a binary operator. -keyword :: Doc -> Doc-keyword = color Red+parensIf :: Bool -> Doc -> Doc+parensIf False = id+parensIf True  = parens  -- | Pretty-print a variable. ppVariable :: Variable (a :: Hakaru) -> Doc-ppVariable x = hint-    where-    hint-        | Text.null (varHint x) = PP.char 'x'  <> (PP.int . fromNat . varID) x -- We used to use '_' but...-        | otherwise             = (PP.text . Text.unpack . varHint) x--ppVariableWithType :: Variable (a :: Hakaru) -> (Doc, Doc)-ppVariableWithType x = (hint, (prettyType 0 . varType) x)-    where-    hint-        | Text.null (varHint x) = PP.char 'x' <> (PP.int . fromNat . varID) x -- We used to use '_' but...-        | otherwise             = (PP.text . Text.unpack . varHint) x+ppVariable x+    | Text.null (varHint x) = text ('x' : show (fromNat (varID x))) -- We used to use '_' but...+    | otherwise             = text (Text.unpack (varHint x)) --- BUG: we still use this in a few places. I'm pretty sure they should all actually be 'ppBinder2', in which case we can delete this function and just use that one.-ppBinder :: (ABT Term abt) => abt xs a -> Docs-ppBinder e =-    case go [] (viewABT e) of-    ([],  body) -> body-    (vars,body) -> PP.char '\\' <> PP.sep vars <+> PP.text "-> " : body+ppBinder :: (ABT Term abt) => abt xs a -> ([Doc], Doc)+ppBinder e = go [] (viewABT e)     where-    go :: (ABT Term abt) => [Doc] -> View (Term abt) xs a -> ([Doc],Docs)+    go :: (ABT Term abt) => [Doc] -> View (Term abt) xs a -> ([Doc], Doc)     go xs (Bind x v) = go (ppVariable x : xs) v-    go xs (Var  x)   = (reverse xs, [ppVariable x])-    go xs (Syn  t)   = (reverse xs, prettyPrec_ 0 (LC_ (syn t)))---ppBinder2prec :: (ABT Term abt) => Int -> abt xs a -> ([Doc], [Doc], Docs)-ppBinder2prec p e = unpackVarTypes $ go [] (viewABT e)-    where-    unpackVarTypes (varTypes, body) =-        (map fst varTypes, map snd varTypes, body)+    go xs (Var  x)   = (reverse xs, ppVariable x)+    go xs (Syn  t)   = (reverse xs, pretty (syn t)) -    go :: (ABT Term abt) => [(Doc, Doc)] -> View (Term abt) xs a -> ([(Doc, Doc)],Docs)-    go xs (Bind x v) = go (ppVariableWithType x : xs) v-    go xs (Var  x)   = (reverse xs, [ppVariable x])-    go xs (Syn  t)   = (reverse xs, prettyPrec_ p (LC_ (syn t)))+ppBinderAsFun :: forall abt xs a . ABT Term abt => abt xs a -> Doc+ppBinderAsFun e =+  let (vars, body) = ppBinder e in+  if null vars then body else sep [fsep vars <> colon, body] -ppBinder2 :: (ABT Term abt) => abt xs a -> ([Doc], [Doc], Docs)-ppBinder2 = ppBinder2prec 0 +ppBinder1 :: (ABT Term abt) => abt '[x] a -> (Doc, Doc, Doc)+ppBinder1 e = caseBind e $ \x v ->+              (ppVariable x,+               prettyType 0 (varType x),+               caseVarSyn v ppVariable (pretty . syn))  -- TODO: since switching to ABT2, this instance requires -XFlexibleContexts; we should fix that if we can -- BUG: since switching to ABT2, this instance requires -XUndecidableInstances; must be fixed! instance (ABT Term abt) => Pretty (LC_ abt) where   prettyPrec_ p (LC_ e) =-    caseVarSyn e ((:[]) . ppVariable) $ \t ->+    caseVarSyn e ppVariable $ \t ->         case t of         o :$ es      -> ppSCon p o es         NaryOp_ o es ->             if Seq.null es then identityElement o             else                 case o of-                  And      -> parens (p > 3)-                              . PP.punctuate (PP.text " && ")-                              . map (prettyPrec 3)-                              $ F.toList es-                  Or       -> parens (p > 2)-                              . PP.punctuate (PP.text " || ")-                              . map (prettyPrec 2)-                              $ F.toList es-                  Xor      -> parens (p > 0)-                              . PP.punctuate (PP.text " != ")-                              . map (prettyPrec 0)-                              $ F.toList es-                -- BUG: even though 'Iff' is associative (in Boolean algebras), we should not support n-ary uses in our *surface* syntax. Because it's too easy for folks to confuse "a <=> b <=> c" with "(a <=> b) /\ (b <=> c)".-                  Iff      -> [F.foldl1 (\a b -> toDoc $ ppFun p "iff" [a, b])-                                         (fmap (toDoc . ppArg) es)]-                  (Min  _) -> [F.foldl1 (\a b -> toDoc $ ppFun p "min" [a, b])-                                         (fmap (toDoc . ppArg) es)]-                  (Max  _) -> [F.foldl1 (\a b -> toDoc $ ppFun p "max" [a, b])-                                          (fmap (toDoc . ppArg) es)]-                  (Sum  _) -> case Seq.viewl es of-                                Seq.EmptyL -> [PP.text "0"]-                                (e' Seq.:< es') -> parens (p > 6) $-                                    F.foldl (\a b -> a ++ (ppNaryOpSum 6 b))-                                            [prettyPrec 6 e']-                                            es'-                  (Prod _) ->  case Seq.viewl es of-                                Seq.EmptyL -> [PP.text "1"]-                                (e' Seq.:< es') -> parens (p > 7) $-                                    F.foldl (\a b -> a ++ (ppNaryOpProd 7 b))-                                            [prettyPrec 7 e']-                                            es'+                  And    -> asOp 3 "&&" es+                  Or     -> asOp 2 "||" es+                  Xor    -> asFun "xor" es+                  Iff    -> asFun "iff" es+                  Min  _ -> asFun "min" es+                  Max  _ -> asFun "max" es -          where identityElement :: NaryOp a -> Docs-                identityElement And      = [PP.text "true"]-                identityElement Or       = [PP.text "false"]-                identityElement Xor      = [PP.text "false"]-                identityElement Iff      = [PP.text "true"]+                  Sum  _ -> case F.toList es of+                    [e1] -> prettyPrec p e1+                    e1:es' -> parensIf (p > 6) $ sep $+                              prettyPrec 6 e1 :+                              map ppNaryOpSum es'++                  Prod _ -> case F.toList es of+                    [e1] -> prettyPrec p e1+                    e1:e2:es' -> parensIf (p > 7) $ sep $+                                 d1' :+                                 ppNaryOpProd second e2 :+                                 map (ppNaryOpProd False) es'+                      where d1 = prettyPrec 7 e1+                            (d1', second) =+                              caseVarSyn e1 (const (d1,False)) (\t -> case t of+                                -- Use parens to distinguish division into 1+                                -- from recip+                                Literal_ (LNat 1) -> (parens d1, False)+                                Literal_ (LNat _) -> (d1, True)+                                _                 -> (d1, False))++          where identityElement :: NaryOp a -> Doc+                identityElement And      = text "true"+                identityElement Or       = text "false"+                identityElement Xor      = text "false"+                identityElement Iff      = text "true"                 identityElement (Min  _) = error "min cannot be used with no arguments"                 identityElement (Max  _) = error "max cannot be used with no arguments"-                identityElement (Sum  _) = [PP.text "0"]-                identityElement (Prod _) = [PP.text "1"]+                identityElement (Sum  _) = text "0"+                identityElement (Prod _) = text "1" +                asOp :: (ABT Term abt)+                     => Int -> String -> Seq.Seq (abt '[] a) -> Doc+                asOp p0 s = parensIf (p > p0)+                          . sepByR s+                          . map (prettyPrec (p0 + 1))+                          . F.toList++                asFun :: (ABT Term abt)+                      => String -> Seq.Seq (abt '[] a) -> Doc+                asFun   s = ($ p)+                          . F.foldr1 (\a b p' -> ppFun p' s [a, b])+                          . fmap (flip prettyPrec)+         Literal_ v    -> prettyPrec_ p v-        Empty_   _    -> [PP.text "empty"]-        Array_ e1 e2  ->-            let (vars, _, body) = ppBinder2 e2 in-            [ PP.text "array"-              <+> toDoc vars-              <+> PP.text "of"-              <+> toDoc (ppArg e1)-              <> PP.colon <> PP.space-            , PP.nest 1 (toDoc body)]+        Empty_   typ  -> parensIf (p > 5) (text "[]." <+> prettyType 0 typ)+        Array_ e1 e2  -> parensIf (p > 0) $+            let (var, _, body) = ppBinder1 e2 in+            sep [ sep [ text "array" <+> var+                      , text "of" <+> pretty e1 <> colon ]+                , body ] -        ArrayLiteral_ es -> ppList $ fmap (prettyPrec 0) es+        ArrayLiteral_ es -> ppList $ map pretty es          Datum_ d      -> prettyPrec_ p (fmap11 LC_ d)-        Case_  e1 bs  -> parens True $-            -- TODO: should we also add hints to the 'Case_' constructor to know whether it came from 'if_', 'unpair', etc?-            [ PP.text "match"-              <+> (toDoc $ ppArg e1)-              <> PP.colon <> PP.space-            , PP.nest 1 (PP.vcat (map (toDoc . prettyPrec_ 0) bs))-            ]-        Superpose_ pes ->-            PP.punctuate (PP.text " <|> ") $ L.toList $ fmap ppWeight pes-          where ppWeight (w,m)-                    | (PP.render $ pretty w) == "1" =-                        toDoc $ ppArg m-                    | otherwise                 =-                        toDoc $ ppFun p "weight" [pretty w, pretty m]+        Case_  e1 [Branch (PDatum h2 _) e2, Branch (PDatum h3 _) e3]+            | "true"  <- Text.unpack h2+            , "false" <- Text.unpack h3+            , ([], body2) <- ppBinder e2+            , ([], body3) <- ppBinder e3+            -> parensIf (p > 0) $+               sep [ sep [ text "if" <+> pretty e1 <> colon, nest 2 body2 ]+                   , sep [ text "else" <> colon, nest 2 body3 ] ]+        Case_  e1 bs  -> parensIf (p > 0) $+            sep [ text "match" <+> pretty e1 <> colon+                , vcat (map (prettyPrec_ 0) bs) ]+        Superpose_ pes -> case L.toList pes of+                            [wm] -> ppWeight p wm+                            wms  -> parensIf (p > 1)+                                  . sepByR "<|>"+                                  $ map (ppWeight 2) wms+          where ppWeight p (w,m)+                    | Syn (Literal_ (LProb 1)) <- viewABT w+                    = prettyPrec p m+                    | otherwise+                    = ppApply2 p "weight" w m -        Reject_ typ -> [PP.text "reject." <+> prettyType 0 typ]+        Reject_ typ -> parensIf (p > 5) (text "reject." <+> prettyType 0 typ) +        Bucket lo hi red -> ppFun p "rbucket"+                            [ flip prettyPrec lo, flip prettyPrec hi+                            , flip prettyPrec_ red ]++instance ABT Term abt => Pretty (Reducer abt xs) where+  prettyPrec_ = flip ppr where+    ppRbinder :: abt xs1 a -> Int -> Doc+    ppRbinder f p =+      let (vs,b) = ppBinder f+      in parensIf (p > 0) $ sep [ sepComma vs <> colon, b ]++    ppr :: Reducer abt xs1 a -> Int -> Doc+    ppr red p =+      case red of+        Red_Fanout l r  -> ppFun p "rfanout"+                             [ ppr l+                             , ppr r ]+        Red_Index s k r -> ppFun p "rindex"+                             [ ppRbinder s+                             , ppRbinder k+                             , ppr r ]+        Red_Split b l r -> ppFun p "rsplit"+                             [ ppRbinder b+                             , ppr l+                             , ppr r ]+        Red_Nop         -> text "rnop"+        Red_Add _ k     -> ppFun p "radd" [ ppRbinder k ]+ ppNaryOpSum-    :: forall abt a-    . (ABT Term abt)-    => Int-    -> abt '[] a-    -> Docs-ppNaryOpSum p e =-    caseVarSyn e (const $ prefixToTerm "+" e) $ \t ->+    :: forall abt a . (ABT Term abt) => abt '[] a -> Doc+ppNaryOpSum e =+    caseVarSyn e (const d) $ \t ->         case t of-        Literal_ (LInt  i) | i < 0 ->      prefixToTerm "-" (syn . Literal_ . LInt  . abs $ i)-        Literal_ (LReal i) | i < 0 ->      prefixToTerm "-" (syn . Literal_ . LReal . abs $ i)-        PrimOp_ (Negate _) :$ e1 :* End -> prefixToTerm "-" e1-        _ -> prefixToTerm "+" e-  where prefixToTerm :: forall a. String -> abt '[] a -> Docs-        prefixToTerm s e = [ PP.space <> PP.text s <> PP.space-                           , prettyPrec p e-                           ]+        PrimOp_ (Negate _) :$ e1 :* End -> text "-" <+> prettyPrec 7 e1+        _ -> d+  where d = text "+" <+> prettyPrec 7 e  ppNaryOpProd-    :: forall abt a-    . (ABT Term abt)-    => Int-    -> abt '[] a-    -> Docs-ppNaryOpProd p e =-    caseVarSyn e (const $ prefixToTerm "*" e) $ \t ->+    :: forall abt a . (ABT Term abt) => Bool -> abt '[] a -> Doc+ppNaryOpProd second e =+    caseVarSyn e (const d) $ \t ->         case t of-        Literal_ (LProb i) | numerator i == 1 -> -          prefixToTerm "/" (syn . Literal_ . LProb . fromIntegral . denominator $ i)-        Literal_ (LReal i) | numerator i == 1 -> -          prefixToTerm "/" (syn . Literal_ . LReal . fromIntegral . denominator $ i)-        PrimOp_ (Recip _) :$ e1 :* End -> prefixToTerm "/" e1-        _ -> prefixToTerm "*" e-  where prefixToTerm :: forall a. String -> abt '[] a -> Docs-        prefixToTerm s e = [ PP.space <> PP.text s <> PP.space-                           , prettyPrec p e-                           ]+        PrimOp_ (Recip _) :$ e1 :* End ->+            if not second then d' else+            caseVarSyn e1 (const d') $ \t' ->+                case t' of+                -- Use parens to distinguish division of nats+                -- from prob literal+                Literal_ (LNat _) -> text "/" <+> parens (pretty e1)+                _ -> d'+          where d' = text "/" <+> prettyPrec 8 e1+        _ -> d+  where d = text "*" <+> prettyPrec 8 e  -- | Pretty-print @(:$)@ nodes in the AST.-ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Docs+ppSCon :: (ABT Term abt) => Int -> SCon args a -> SArgs abt args -> Doc ppSCon p Lam_ = \(e1 :* End) ->-    let (vars, types, body) = ppBinder2prec 11 e1 in-    parens (p < 11)-    [ PP.text "fn" <+> toDoc vars-                   <+> toDoc types-                    <> PP.colon <> PP.space-    , PP.nest 1 (toDoc body)]+    let (var, typ, body) = ppBinder1 e1 in+    parensIf (p > 0) $+    sep [ text "fn" <+> var <+> typ <> colon+        , body ]  --ppSCon p App_ = \(e1 :* e2 :* End) -> ppArg e1 ++ parens True (ppArg e2)-ppSCon _ App_ = \(e1 :* e2 :* End) -> prettyApps e1 e2+ppSCon p App_ = \(e1 :* e2 :* End) -> prettyApps p e1 e2 -ppSCon _ Let_ = \(e1 :* e2 :* End) ->-    {--    caseBind e2 $ \x e2' ->-        (ppVariable x <+> PP.equals <+> PP.nest n (pretty e1))-        : pretty e2'-    -}-    let (vars, _, body) = ppBinder2 e2 in-    [toDoc vars <+> PP.equals <+> toDoc (ppArg e1)-    PP.$$ (toDoc body)]+ppSCon p Let_ = \(e1 :* e2 :* End) ->+    -- TODO: generate 'def' if possible+    let (var, _, body) = ppBinder1 e2 in+    parensIf (p > 0) $+    var <+> equals <+> pretty e1 $$ body {- ppSCon p (Ann_ typ) = \(e1 :* End) ->-    [toDoc (ppArg e1) <+> PP.text "::" <+> prettyType p typ]+    parensIf (p > 5) (prettyPrec 6 e1 <> text "." <+> prettyType 0 typ) -}  ppSCon p (PrimOp_     o) = \es          -> ppPrimOp     p o es@@ -289,233 +312,227 @@ ppSCon p (CoerceTo_   c) = \(e1 :* End) -> ppCoerceTo   p c e1 ppSCon p (UnsafeFrom_ c) = \(e1 :* End) -> ppUnsafeFrom p c e1 ppSCon p (MeasureOp_  o) = \es          -> ppMeasureOp  p o es-ppSCon _ Dirac = \(e1 :* End) -> [PP.text "return" <+> toDoc (ppArg e1)]-ppSCon _ MBind = \(e1 :* e2 :* End) ->-    let (vars, _, body) = ppBinder2 e2 in-    [toDoc vars <+> PP.text "<~" <+> toDoc (ppArg e1)-        PP.$$ (toDoc body)]+ppSCon p Dirac = \(e1 :* End) ->+    parensIf (p > 0) $+    text "return" <+> pretty e1+ppSCon p MBind = \(e1 :* e2 :* End) ->+    let (var, _, body) = ppBinder1 e2 in+    parensIf (p > 0) $+    var <+> text "<~" <+> pretty e1 $$ body  ppSCon p Plate = \(e1 :* e2 :* End) ->-    let (vars, types, body) = ppBinder2 e2 in-    [ PP.text "plate"-      <+> toDoc vars-      <+> PP.text "of"-      <+> (toDoc $ ppArg e1)-      <> PP.colon <> PP.space-    , PP.nest 1 (toDoc body)-    ]+    let (var, _, body) = ppBinder1 e2 in+    parensIf (p > 0) $+    sep [ sep [ text "plate" <+> var+              , text "of" <+> pretty e1 <> colon ]+        , body ]  ppSCon p Chain = \(e1 :* e2 :* e3 :* End) ->-    ppFun 11 "chain"-        [ toDoc (ppArg e1)-        , toDoc (ppArg e2) <+> PP.char '$'-        , toDoc $ ppBinder e2-        ]+    let (var, _, body) = ppBinder1 e3 in+    parensIf (p > 0) $+    sep [ sep [ text "chain" <+> var+              , text "from" <+> pretty e2+              , text "of" <+> pretty e1 <> colon ]+        , body ]  ppSCon p Integrate = \(e1 :* e2 :* e3 :* End) ->-    let (vars, types, body) = ppBinder2 e3 in-    [ PP.text "integrate"-      <+> toDoc vars-      <+> PP.text "from"-      <+> (toDoc $ ppArg e1)-      <+> PP.text "to"-      <+> (toDoc $ ppArg e2)-      <> PP.colon <> PP.space-    , PP.nest 1 (toDoc body)-    ]+    let (var, _, body) = ppBinder1 e3 in+    parensIf (p > 0) $+    sep [ sep [ text "integrate" <+> var+              , text "from" <+> pretty e1+              , text "to" <+> pretty e2 <> colon ]+        , body ]  ppSCon p (Summate _ _) = \(e1 :* e2 :* e3 :* End) ->-    let (vars, types, body) = ppBinder2 e3 in-    parens True $-    [ PP.text "summate"-      <+> toDoc vars-      <+> PP.text "from"-      <+> (toDoc $ ppArg e1)-      <+> PP.text "to"-      <+> (toDoc $ ppArg e2)-      <> PP.colon <> PP.space-    , PP.nest 1 (toDoc body)-    ]+    let (var, _, body) = ppBinder1 e3 in+    parensIf (p > 0) $+    sep [ sep [ text "summate" <+> var+              , text "from" <+> pretty e1+              , text "to" <+> pretty e2 <> colon ]+        , body ]  ppSCon p (Product _ _) = \(e1 :* e2 :* e3 :* End) ->-    let (vars, types, body) = ppBinder2 e3 in-    parens True $-    [ PP.text "product"-      <+> toDoc vars-      <+> PP.text "from"-      <+> (toDoc $ ppArg e1)-      <+> PP.text "to"-      <+> (toDoc $ ppArg e2)-      <> PP.colon <> PP.space-    , PP.nest 1 (toDoc body)-    ]--ppSCon p Expect = \(e1 :* e2 :* End) ->-    let (vars, types, body) = ppBinder2 e2 in-    [ PP.text "expect"-      <+> toDoc vars-      <+> (toDoc . parens True $ ppArg e1)-      <> PP.colon-    , PP.nest 1 (toDoc body)-    ]+    let (var, _, body) = ppBinder1 e3 in+    parensIf (p > 0) $+    sep [ sep [ text "product" <+> var+              , text "from" <+> pretty e1+              , text "to" <+> pretty e2 <> colon ]+        , body ] -ppSCon p Observe = \(e1 :* e2 :* End) ->-    [ PP.text "observe"-      <+> (toDoc $ ppArg e1)-      <+> (toDoc $ ppArg e2)-    ]+ppSCon p (Transform_ t) = ppTransform p t +ppTransform :: (ABT Term abt)+            => Int -> Transform args a+            -> SArgs abt args -> Doc+ppTransform p t es =+  case t of+    Expect ->+      case es of+        e1 :* e2 :* End ->+          let (var, _, body) = ppBinder1 e2 in+          parensIf (p > 0) $+          sep [ text "expect" <+> var <+> pretty e1 <> colon+              , body ]+    _ -> ppApply p (transformName t) es -ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Docs-ppCoerceTo =+ppCoerceTo :: ABT Term abt => Int -> Coercion a b -> abt '[] a -> Doc+ppCoerceTo p c = ppApply1 p f     -- BUG: this may not work quite right when the coercion isn't one of the special named ones...-    \p c e -> ppFun p (prettyShow c) [toDoc $ ppArg e]     where-    prettyShow (CCons (Signed HRing_Real) CNil)           = "prob2real"-    prettyShow (CCons (Signed HRing_Int)  CNil)           = "nat2int"-    prettyShow (CCons (Continuous HContinuous_Real) CNil) = "int2real"-    prettyShow (CCons (Continuous HContinuous_Prob) CNil) = "nat2prob"-    prettyShow (CCons (Continuous HContinuous_Prob)-        (CCons (Signed HRing_Real) CNil))                 = "nat2real"-    prettyShow (CCons (Signed HRing_Int)-        (CCons (Continuous HContinuous_Real) CNil))       = "nat2real"-    prettyShow c = "coerceTo_ " ++ showsPrec 11 c ""+    f = case c of+          Signed HRing_Real             `CCons` CNil -> "prob2real"+          Signed HRing_Int              `CCons` CNil -> "nat2int"+          Continuous HContinuous_Real   `CCons` CNil -> "int2real"+          Continuous HContinuous_Prob   `CCons` CNil -> "nat2prob"+          Continuous HContinuous_Prob   `CCons`+            Signed HRing_Real           `CCons` CNil -> "nat2real"+          Signed HRing_Int              `CCons`+            Continuous HContinuous_Real `CCons` CNil -> "nat2real"+          _ -> "coerceTo_ (" ++ show c ++ ")"  -ppUnsafeFrom :: ABT Term abt => Int -> Coercion a b -> abt '[] b -> Docs-ppUnsafeFrom =+ppUnsafeFrom :: ABT Term abt => Int -> Coercion a b -> abt '[] b -> Doc+ppUnsafeFrom p c = ppApply1 p f     -- BUG: this may not work quite right when the coercion isn't one of the special named ones...-    \p c e -> ppFun p (prettyShow c) [toDoc $ ppArg e]     where-    prettyShow (CCons (Signed HRing_Real) CNil) = "real2prob"-    prettyShow (CCons (Signed HRing_Int)  CNil) = "int2nat"-    prettyShow c = "unsafeFrom_ " ++ showsPrec 11 c ""+    f = case c of+          Signed HRing_Real `CCons` CNil -> "real2prob"+          Signed HRing_Int  `CCons` CNil -> "int2nat"+          _ -> "unsafeFrom_ (" ++ show c ++ ")"   -- | Pretty-print a type. prettyType :: Int -> Sing (a :: Hakaru) -> Doc-prettyType _ SNat         = PP.text "nat"-prettyType _ SInt         = PP.text "int"-prettyType _ SProb        = PP.text "prob"-prettyType _ SReal        = PP.text "real"-prettyType p (SMeasure a) = PP.text "measure" <> PP.parens (prettyType p a)-prettyType p (SArray   a) = PP.text "array" <> PP.parens (prettyType p a)--- HACK: precedence of function types-prettyType p (SFun   a b) = PP.parens (prettyType p a <+> PP.text "->" <+> prettyType p b)-prettyType p typ          =-    case typ of-    SData (STyCon sym `STyApp` a `STyApp` b) _-      | Just Refl <- jmEq1 sym sSymbol_Pair-      -> toDoc $ ppFun p "pair" [prettyType p a, prettyType p b]-      | Just Refl <- jmEq1 sym sSymbol_Either-      -> toDoc $ ppFun p "either" [prettyType p a, prettyType p b]-    SData (STyCon sym `STyApp` a) _-      | Just Refl <- jmEq1 sym sSymbol_Maybe-      -> toDoc $ ppFun p "maybe" [prettyType p a]-    SData (STyCon sym) _-      | Just Refl <- jmEq1 sym sSymbol_Bool-      -> PP.text "bool"-      | Just Refl <- jmEq1 sym sSymbol_Unit-      -> PP.text "unit"-    _ -> PP.text (showsPrec 11 typ "")+prettyType _ SNat         = text "nat"+prettyType _ SInt         = text "int"+prettyType _ SProb        = text "prob"+prettyType _ SReal        = text "real"+prettyType p (SFun   a b) = parensIf (p > 0)+                          $ sep [ prettyType 1 a <+> text "->"+                                , prettyType 0 b ]+prettyType p (SMeasure a) = ppFun p "measure" [flip prettyType a]+prettyType p (SArray   a) = ppFun p "array" [flip prettyType a]+prettyType p (SData (STyCon sym `STyApp` a `STyApp` b) _)+    | Just Refl <- jmEq1 sym sSymbol_Pair+    = ppFun p "pair" [flip prettyType a, flip prettyType b]+    | Just Refl <- jmEq1 sym sSymbol_Either+    = ppFun p "either" [flip prettyType a, flip prettyType b]+prettyType p (SData (STyCon sym `STyApp` a) _)+    | Just Refl <- jmEq1 sym sSymbol_Maybe+    = ppFun p "maybe" [flip prettyType a]+prettyType p (SData (STyCon sym) _)+    | Just Refl <- jmEq1 sym sSymbol_Bool+    = text "bool"+    | Just Refl <- jmEq1 sym sSymbol_Unit+    = text "unit"+prettyType _ typ+    = parens (text (show typ))   -- | Pretty-print a 'PrimOp' @(:$)@ node in the AST. ppPrimOp     :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)-    => Int -> PrimOp typs a -> SArgs abt args -> Docs-ppPrimOp p Not  = \(e1 :* End)       -> ppApply1 p "not" e1-ppPrimOp p Impl = \(e1 :* e2 :* End) ->-    -- TODO: make prettier-    ppFun p "syn"-        [ toDoc $ ppFun 11 "Impl"-            [ toDoc $ ppArg e1-            , toDoc $ ppArg e2-            ]]-ppPrimOp p Diff = \(e1 :* e2 :* End) ->-    -- TODO: make prettier-    ppFun p "syn"-        [ toDoc $ ppFun 11 "Diff"-            [ toDoc $ ppArg e1-            , toDoc $ ppArg e2-            ]]-ppPrimOp p Nand = \(e1 :* e2 :* End) -> ppApply2 p "nand" e1 e2 -- TODO: make infix...-ppPrimOp p Nor  = \(e1 :* e2 :* End) -> ppApply2 p "nor" e1 e2 -- TODO: make infix...-ppPrimOp _ Pi        = \End               -> [PP.text "pi"]-ppPrimOp p Sin       = \(e1 :* End)       -> ppApply1 p "sin"   e1-ppPrimOp p Cos       = \(e1 :* End)       -> ppApply1 p "cos"   e1-ppPrimOp p Tan       = \(e1 :* End)       -> ppApply1 p "tan"   e1-ppPrimOp p Asin      = \(e1 :* End)       -> ppApply1 p "asin"  e1-ppPrimOp p Acos      = \(e1 :* End)       -> ppApply1 p "acos"  e1-ppPrimOp p Atan      = \(e1 :* End)       -> ppApply1 p "atan"  e1-ppPrimOp p Sinh      = \(e1 :* End)       -> ppApply1 p "sinh"  e1-ppPrimOp p Cosh      = \(e1 :* End)       -> ppApply1 p "cosh"  e1-ppPrimOp p Tanh      = \(e1 :* End)       -> ppApply1 p "tanh"  e1-ppPrimOp p Asinh     = \(e1 :* End)       -> ppApply1 p "asinh" e1-ppPrimOp p Acosh     = \(e1 :* End)       -> ppApply1 p "acosh" e1-ppPrimOp p Atanh     = \(e1 :* End)       -> ppApply1 p "atanh" e1-ppPrimOp p RealPow   = \(e1 :* e2 :* End) -> ppBinop "**" 8 RightAssoc p e1 e2-ppPrimOp p Exp       = \(e1 :* End)       -> ppApply1 p "exp"   e1-ppPrimOp p Log       = \(e1 :* End)       -> ppApply1 p "log"   e1-ppPrimOp _ (Infinity _) = \End               -> [PP.text "∞"]-ppPrimOp p GammaFunc    = \(e1 :* End)       -> ppApply1 p "gammaFunc" e1-ppPrimOp p BetaFunc     = \(e1 :* e2 :* End) -> ppApply2 p "betaFunc" e1 e2+    => Int -> PrimOp typs a -> SArgs abt args -> Doc+ppPrimOp p Not          (e1 :* End)+  | Syn (PrimOp_ Less{}  :$ e2 :* e3 :* End) <- viewABT e1+  = ppBinop "<=" 4 NonAssoc p e3 e2+  | Syn (PrimOp_ Equal{} :$ e2 :* e3 :* End) <- viewABT e1+  = ppBinop "/=" 4 NonAssoc p e2 e3+  | otherwise+  = ppApply1 p "not" e1+ppPrimOp p Impl         (e1 :* e2 :* End) = ppApply2 p "impl" e1 e2+ppPrimOp p Diff         (e1 :* e2 :* End) = ppApply2 p "diff" e1 e2+ppPrimOp p Nand         (e1 :* e2 :* End) = ppApply2 p "nand" e1 e2+ppPrimOp p Nor          (e1 :* e2 :* End) = ppApply2 p "nor" e1 e2+ppPrimOp _ Pi           End               = text "pi"+ppPrimOp p Sin          (e1 :* End)       = ppApply1 p "sin"   e1+ppPrimOp p Cos          (e1 :* End)       = ppApply1 p "cos"   e1+ppPrimOp p Tan          (e1 :* End)       = ppApply1 p "tan"   e1+ppPrimOp p Asin         (e1 :* End)       = ppApply1 p "asin"  e1+ppPrimOp p Acos         (e1 :* End)       = ppApply1 p "acos"  e1+ppPrimOp p Atan         (e1 :* End)       = ppApply1 p "atan"  e1+ppPrimOp p Sinh         (e1 :* End)       = ppApply1 p "sinh"  e1+ppPrimOp p Cosh         (e1 :* End)       = ppApply1 p "cosh"  e1+ppPrimOp p Tanh         (e1 :* End)       = ppApply1 p "tanh"  e1+ppPrimOp p Asinh        (e1 :* End)       = ppApply1 p "asinh" e1+ppPrimOp p Acosh        (e1 :* End)       = ppApply1 p "acosh" e1+ppPrimOp p Atanh        (e1 :* End)       = ppApply1 p "atanh" e1+ppPrimOp p RealPow      (e1 :* e2 :* End) = ppBinop "**" 8 RightAssoc p e1 e2+ppPrimOp p Choose       (e1 :* e2 :* End) = ppApply2 p "choose" e1 e2+ppPrimOp p Exp          (e1 :* End)       = ppApply1 p "exp"   e1+ppPrimOp p Log          (e1 :* End)       = ppApply1 p "log"   e1+ppPrimOp _ (Infinity _) End               = text "∞"+ppPrimOp p GammaFunc    (e1 :* End)       = ppApply1 p "gammaFunc" e1+ppPrimOp p BetaFunc     (e1 :* e2 :* End) = ppApply2 p "betaFunc" e1 e2+ppPrimOp p (Equal   _)  (e1 :* e2 :* End) = ppBinop "==" 4 NonAssoc   p e1 e2+ppPrimOp p (Less    _)  (e1 :* e2 :* End) = ppBinop "<"  4 NonAssoc   p e1 e2+ppPrimOp p (NatPow  _)  (e1 :* e2 :* End) = ppBinop "^"  8 RightAssoc p e1 e2+ppPrimOp p (Negate  _)  (e1 :* End)       = ppNegate p e1+ppPrimOp p (Abs     _)  (e1 :* End)       = ppApply1  p "abs"     e1+ppPrimOp p (Signum  _)  (e1 :* End)       = ppApply1  p "signum"  e1+ppPrimOp p (Recip   _)  (e1 :* End)       = ppRecip p e1+ppPrimOp p (NatRoot _)  (e1 :* e2 :* End) = ppNatRoot p e1 e2+ppPrimOp p (Erf _)      (e1 :* End)       = ppApply1  p "erf"     e1+ppPrimOp p Floor        (e1 :* End)       = ppApply1 p "floor"   e1 -ppPrimOp p (Equal   _) = \(e1 :* e2 :* End) -> ppBinop "==" 4 NonAssoc   p e1 e2-ppPrimOp p (Less    _) = \(e1 :* e2 :* End) -> ppBinop "<"  4 NonAssoc   p e1 e2-ppPrimOp p (NatPow  _) = \(e1 :* e2 :* End) -> ppBinop "^"  8 RightAssoc p e1 e2-ppPrimOp p (Negate  _) = \(e1 :* End)       -> ppApply1  p "negate"  e1-ppPrimOp p (Abs     _) = \(e1 :* End)       -> ppApply1  p "abs"     e1-ppPrimOp p (Signum  _) = \(e1 :* End)       -> ppApply1  p "signum"  e1-ppPrimOp p (Recip   _) = \(e1 :* End)       -> ppApply1  p "recip"   e1-ppPrimOp p (NatRoot _) = \(e1 :* e2 :* End) -> ppNatRoot p e1 e2-ppPrimOp p (Erf _)     = \(e1 :* End)       -> ppApply1  p "erf"     e1+ppNegate :: (ABT Term abt) => Int -> abt '[] a -> Doc+ppNegate p e = parensIf (p > 6) $+    caseVarSyn e (const d) $ \t ->+        case t of+        -- Use parens to distinguish between negation of nats/probs+        -- from int/real literal+        Literal_ (LNat  _) -> d'+        Literal_ (LProb _) -> d'+        _                  -> d+    where d  = text "-" <> prettyPrec 7 e+          d' = text "-" <> parens (pretty e) +ppRecip :: (ABT Term abt) => Int -> abt '[] a -> Doc+ppRecip p e = parensIf (p > 7) $+    caseVarSyn e (const d) $ \t ->+        case t of+        -- Use parens to distinguish between reciprocal of nat+        -- from prob literal+        Literal_ (LNat _) -> d'+        _                 -> d+    where d  = text "1/" <+> prettyPrec 8 e+          d' = text "1/" <+> parens (pretty e)  ppNatRoot     :: (ABT Term abt)     => Int     -> abt '[] a     -> abt '[] 'HNat-    -> Docs+    -> Doc ppNatRoot p e1 e2 =-    caseVarSyn e2 (\x -> ppApply2 p "natroot" e1 e2) $ \t ->+    caseVarSyn e2 (const d) $ \t ->         case t of-          Literal_ (LNat 2) -> ppApply1 p "sqrt"    e1-          _                 -> ppApply2 p "natroot" e1 e2+          Literal_ (LNat 2) -> ppApply1 p "sqrt" e1+          _                 -> d+    where d = ppApply2 p "natroot" e1 e2   -- | Pretty-print a 'ArrayOp' @(:$)@ node in the AST. ppArrayOp     :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)-    => Int -> ArrayOp typs a -> SArgs abt args -> Docs-ppArrayOp p (Index   _) = \(e1 :* e2 :* End) ->-    [(toDoc $ parensIf (isArray e1) $ ppArg e1) <>-     PP.text "["        <>-     (toDoc $ ppArg e2) <>-     PP.text "]"]-  where isArray e = caseVarSyn e (const False) $ \t ->-                      case t of-                      Array_ _ _ -> True-                      _          -> False-        parensIf True  e = parens True e-        parensIf False e = e+    => Int -> ArrayOp typs a -> SArgs abt args -> Doc+ppArrayOp p (Index   _) = \(e1 :* e2 :* End) -> parensIf (p > 10)+    $ cat [ prettyPrec 10 e1, nest 2 (brackets (pretty e2)) ]  ppArrayOp p (Size    _) = \(e1 :* End)       -> ppApply1 p "size" e1 ppArrayOp p (Reduce  _) = \(e1 :* e2 :* e3 :* End) ->     ppFun p "reduce"-        [ toDoc $ ppArg e1 -- N.B., @e1@ uses lambdas rather than being a binding form!-        , toDoc $ ppArg e2-        , toDoc $ ppArg e3-        ]+        [ flip prettyPrec e1+        , flip prettyPrec e2+        , flip prettyPrec e3 ]   -- | Pretty-print a 'MeasureOp' @(:$)@ node in the AST. ppMeasureOp     :: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)-    => Int -> MeasureOp typs a -> SArgs abt args -> Docs-ppMeasureOp _ Lebesgue    = \End           -> [PP.text "lebesgue"]-ppMeasureOp _ Counting    = \End           -> [PP.text "counting"]+    => Int -> MeasureOp typs a -> SArgs abt args -> Doc+ppMeasureOp p Lebesgue    = \(e1 :* e2 :* End) -> ppApply2 p "lebesgue" e1 e2+ppMeasureOp _ Counting    = \End           -> text "counting" ppMeasureOp p Categorical = \(e1 :* End)   -> ppApply1 p "categorical" e1 ppMeasureOp p Uniform = \(e1 :* e2 :* End) -> ppApply2 p "uniform"     e1 e2 ppMeasureOp p Normal  = \(e1 :* e2 :* End) -> ppApply2 p "normal"      e1 e2@@ -523,28 +540,36 @@ ppMeasureOp p Gamma   = \(e1 :* e2 :* End) -> ppApply2 p "gamma"       e1 e2 ppMeasureOp p Beta    = \(e1 :* e2 :* End) -> ppApply2 p "beta"        e1 e2 --- BUG: doubles may not properly and unambiguously represent the correct rational! Consider using 'ppRatio' instead. instance Pretty Literal where-    prettyPrec_ _ (LNat  n) = [PP.integer (fromNatural n)]-    prettyPrec_ _ (LInt  i) = [PP.integer i]-    prettyPrec_ p (LProb l) =-        [ppRatio p $ fromNonNegativeRational l]-    prettyPrec_ p (LReal r) = [ppRatio p r]+    prettyPrec_ _ (LNat  n) = integer (fromNatural n)+    prettyPrec_ p (LInt  i) = parensIf (p > 6) $+        if i < 0 then text "-" <> integer (-i)+                 else text "+" <> integer   i+    prettyPrec_ p (LProb l) = parensIf (p > 7) $+        cat [ integer n, text "/" <> integer d ]+        where r = fromNonNegativeRational l+              n = numerator   r+              d = denominator r+    prettyPrec_ p (LReal r) = parensIf (p > 6) $+        if n < 0 then text "-" <> cat [ integer (-n), text "/" <> integer d ]+                 else text "+" <> cat [ integer   n , text "/" <> integer d ]+        where n = numerator   r+              d = denominator r  instance Pretty Value where-    prettyPrec_ _ (VNat  n)    = [PP.int (fromNat n)]-    prettyPrec_ _ (VInt  i)    = [PP.int i]-    prettyPrec_ _ (VProb l)    =-        [PP.double $ LF.fromLogFloat l]-    prettyPrec_ _ (VReal r)    = [PP.double r]+    prettyPrec_ _ (VNat  n)    = integer (fromNatural n)+    prettyPrec_ p (VInt  i)    = parensIf (p > 6) $+        if i < 0 then integer i else text "+" <> integer i+    prettyPrec_ _ (VProb l)    = double (LF.fromLogFloat l)+    prettyPrec_ p (VReal r)    = parensIf (p > 6) $+        if r < 0 then double r else text "+" <> double r     prettyPrec_ p (VDatum d)   = prettyPrec_ p d-    prettyPrec_ _ (VLam _)     = [PP.text "<function>"]-    prettyPrec_ _ (VMeasure _) = [PP.text "<measure>"]-    prettyPrec_ p (VArray a)   =-        ppList . V.toList $ V.map (toDoc . prettyPrec_ p) a+    prettyPrec_ _ (VLam _)     = text "<function>"+    prettyPrec_ _ (VMeasure _) = text "<measure>"+    prettyPrec_ _ (VArray a)   = ppList . V.toList $ V.map (prettyPrec_ 0) a  prettyValue :: Value a -> Doc-prettyValue = toDoc . prettyPrec_ 0+prettyValue = prettyPrec_ 0  instance Pretty f => Pretty (Datum f) where     prettyPrec_ p (Datum hint _typ d)@@ -554,73 +579,66 @@         | otherwise =             case Text.unpack hint of             -- Special cases for certain datums-            "pair"  -> ppFun p ""-                (foldMap11 ((:[]) . toDoc . prettyPrec_ 11) d) -            "true"  -> [PP.text "true"]-            "false" -> [PP.text "false"]-            "unit"  -> [PP.text "()"]+            "pair"  -> ppTuple p (foldMap11 (\e -> [flip prettyPrec_ e]) d) +            "true"  -> text "true"+            "false" -> text "false"+            "unit"  -> text "()"             -- General case-            _       -> ppFun p (Text.unpack hint)-                (foldMap11 ((:[]) . toDoc . prettyPrec_ 11) d)-                ++ [PP.text "." <+> prettyType p _typ]+            f       -> parensIf (p > 5) $+                       ppFun 6 f (foldMap11 (\e -> [flip prettyPrec_ e]) d)+                       <> text "." <+> prettyType 0 _typ   -- HACK: need to pull this out in order to get polymorphic recursion over @xs@-ppPattern :: Int -> [Doc] -> Pattern xs a -> (Docs, [Doc])-ppPattern _ _      PWild = ([PP.text "_"], [])-ppPattern _ (v:vs) PVar  = ([v], vs)-ppPattern p vars   (PDatum hint d0)+ppPattern :: [Doc] -> Pattern xs a -> (Int -> Doc, [Doc])+ppPattern vars   PWild = (const (text "_"), vars)+ppPattern (v:vs) PVar  = (const v         , vs)+ppPattern vars   (PDatum hint d0)     | Text.null hint = error "TODO: prettyPrec_@Pattern"     | otherwise      =         case Text.unpack hint of         -- Special cases for certain pDatums-        "true"  -> ([PP.text "true"],  vars)-        "false" -> ([PP.text "false"], vars)-        "pair"  -> ppFunWithVars p Text.empty+        "true"  -> (const (text "true" ), vars)+        "false" -> (const (text "false"), vars)+        "pair"  -> ppFunWithVars ppTuple         -- General case-        _        -> ppFunWithVars p hint+        f       -> ppFunWithVars (flip ppFun f)     where-    ppFunWithVars p hint = (ppFun p (Text.unpack hint) g, vars')+    ppFunWithVars ppHint = (flip ppHint g, vars')        where (g, vars') = goCode d0 vars -    goCode :: PDatumCode xss vars a -> [Doc] -> (Docs, [Doc])+    goCode :: PDatumCode xss vars a -> [Doc] -> ([Int -> Doc], [Doc])     goCode (PInr d) = goCode   d     goCode (PInl d) = goStruct d -    goStruct :: PDatumStruct xs vars a -> [Doc] -> (Docs, [Doc])+    goStruct :: PDatumStruct xs vars a -> [Doc] -> ([Int -> Doc], [Doc])     goStruct PDone       vars  = ([], vars)     goStruct (PEt d1 d2) vars = (gF ++ gS, vars'')        where (gF, vars')  = goFun d1 vars              (gS, vars'') = goStruct d2 vars'  -    goFun :: PDatumFun x vars a -> [Doc] -> (Docs, [Doc])-    goFun (PKonst d) vars = ([toDoc $ fst r], snd r)-       where r = ppPattern 11 vars d-    goFun (PIdent d) vars = ([toDoc $ fst r], snd r)-       where r = ppPattern 11 vars d+    goFun :: PDatumFun x vars a -> [Doc] -> ([Int -> Doc], [Doc])+    goFun (PKonst d) vars = ([g], vars')+       where (g, vars') = ppPattern vars d+    goFun (PIdent d) vars = ([g], vars')+       where (g, vars') = ppPattern vars d   instance (ABT Term abt) => Pretty (Branch a abt) where-    -- BUG: we can't actually use the HOAS API here, since we-    --      aren't using a Prelude-defined @branch@...-    -- HACK: don't *always* print parens; pass down the precedence to-    --       'ppBinder' to have them decide if they need to or not.     prettyPrec_ p (Branch pat e) =-        let (vars, _, body) = ppBinder2 e in-        [ (toDoc . fst $ ppPattern 11 vars pat) <> PP.colon <> PP.space-        , PP.nest 1 $ toDoc $ body-        ]+        let (vars, body) = ppBinder e+            (pp, []) = ppPattern vars pat+        in sep [ pp 0 <> colon, nest 2 body ]  -----------------------------------------------------------------type DList a = [a] -> [a]--prettyApps :: (ABT Term abt) => abt '[] (a ':-> b) -> abt '[] a -> Docs-prettyApps = \ e1 e2 ->+prettyApps :: (ABT Term abt) => Int -> abt '[] (a ':-> b) -> abt '[] a -> Doc+prettyApps = \ p e1 e2 ->+{- TODO: confirm not using reduceLams     case reduceLams e1 e2 of     Just e2' -> ppArg e2'     Nothing  ->-      let (d, vars) = collectApps e1 (pretty e2 :) in-      [d <> ppTuple (vars [])]+-}+      uncurry (ppApp p) (collectApps e1 [flip prettyPrec e2])     where     reduceLams         :: (ABT Term abt)@@ -633,79 +651,56 @@                 Just (subst x e2 e1')             _                 -> Nothing +    -- collectApps makes sure f(x,y) is not printed f(x)(y)     collectApps         :: (ABT Term abt)-        => abt '[] (a ':-> b) -> DList Doc -> (Doc, DList Doc)+        => abt '[] (a ':-> b) -> [Int -> Doc] -> (Int -> Doc, [Int -> Doc])     collectApps e es = -        caseVarSyn e (\x -> (ppVariable x, es)) $ \t ->+        caseVarSyn e (const ret) $ \t ->             case t of-            App_ :$ e1 :* e2 :* End -> collectApps e1 ((pretty e2 :) . es)-            _                       -> (pretty e, es)+            App_ :$ e1 :* e2 :* End -> collectApps e1 (flip prettyPrec e2 : es)+            _                       -> ret+        where ret = (flip prettyPrec e, es)  -prettyLams :: (ABT Term abt) => abt '[a] b -> Doc-prettyLams = \e ->-    let (d, vars) = collectLams e id in-    PP.char '\\' <+> PP.sep (vars []) <+> PP.text "->" <+> d-    where-    collectLams-        :: (ABT Term abt)-        => abt '[a] b -> DList Doc -> (Doc, DList Doc)-    collectLams e xs = -        caseBind e $ \x e' ->-            let xs' = xs . (ppVariable x :) in-            caseVarSyn e' (\y -> (ppVariable y, xs')) $ \t ->-                case t of-                Lam_ :$ e1 :* End -> collectLams e1 xs'-                _                 -> (pretty e', xs') ---- | For the \"@lam $ \x ->\n@\"  style layout.-adjustHead :: (Doc -> Doc) -> Docs -> Docs-adjustHead f []     = [f (toDoc [])]-adjustHead f (d:ds) = f d : ds--parens :: Bool -> Docs -> Docs-parens True  ds = [PP.parens (PP.nest 1 (toDoc ds))]-parens False ds = [PP.parens (toDoc ds)]+ppList :: [Doc] -> Doc+ppList = brackets . sepComma -ppList :: [Doc] -> Docs-ppList = (:[]) . PP.brackets . PP.nest 1 . PP.fsep . PP.punctuate PP.comma+ppTuple :: Int -> [Int -> Doc] -> Doc+ppTuple _ = parens . sepComma . map ($ 0) -ppTuple :: [Doc] -> Doc-ppTuple = PP.parens . PP.sep . PP.punctuate PP.comma+ppApp :: Int -> (Int -> Doc) -> [Int -> Doc] -> Doc+ppApp p f ds = parensIf (p > 10)+             $ cat [ f 10, nest 2 (ppTuple 11 ds) ] --- TODO: why does this take the precedence argument if it doesn't care?-ppFun :: Int -> String -> [Doc] -> Docs-ppFun _ f [] = [PP.text f <> PP.text "()"]-ppFun _ f ds = [PP.text f <> ppTuple ds]+ppFun :: Int -> String -> [Int -> Doc] -> Doc+ppFun p = ppApp p . const . text -ppArg :: (ABT Term abt) => abt '[] a -> Docs-ppArg = prettyPrec_ 11 . LC_+ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Doc+ppApply1 p f e1 = ppFun p f [flip prettyPrec e1] -ppApply1 :: (ABT Term abt) => Int -> String -> abt '[] a -> Docs-ppApply1 p f e1 = ppFun p f [toDoc $ ppArg e1]+ppApply2 :: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Doc+ppApply2 p f e1 e2 = ppFun p f [flip prettyPrec e1, flip prettyPrec e2] -ppApply2-    :: (ABT Term abt) => Int -> String -> abt '[] a -> abt '[] b -> Docs-ppApply2 p f e1 e2 = ppFun p f [toDoc $ ppArg e1, toDoc $ ppArg e2]+ppApply :: ABT Term abt => Int -> String+        -> SArgs abt xs -> Doc+ppApply p f es =+  ppFun p f $ foldMap21 (pure . const . ppBinderAsFun) es  ppBinop     :: (ABT Term abt)     => String -> Int -> Associativity-    -> Int -> abt '[] a -> abt '[] b -> Docs+    -> Int -> abt '[] a -> abt '[] b -> Doc ppBinop op p0 assoc =-    let (p1,p2) =+    let (p1,p2,f1,f2) =             case assoc of-            LeftAssoc  -> (p0, 1 + p0)-            RightAssoc -> (1 + p0, p0)-            NonAssoc   -> (1 + p0, 1 + p0)+            NonAssoc   -> (1 + p0, 1 + p0, id, (text op <+>))+            LeftAssoc  -> (    p0, 1 + p0, id, (text op <+>))+            RightAssoc -> (1 + p0,     p0, (<+> text op), id)     in \p e1 e2 ->-        parens (p > p0)-            [ prettyPrec p1 e1-            , PP.space <> PP.text op <> PP.space-            , prettyPrec p2 e2-            ]+        parensIf (p > p0) $ sep [ f1 (prettyPrec p1 e1)+                                , f2 (prettyPrec p2 e2) ]  ---------------------------------------------------------------- ----------------------------------------------------------- fin.