inferno-types (empty) → 0.1.0.0
raw patch · 9 files changed
+2262/−0 lines, 9 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, base64-bytestring, bifunctors, bytestring, cereal, containers, cryptonite, deepseq, hashable, megaparsec, memory, mtl, prettyprinter, quickcheck-arbitrary-adt, quickcheck-instances, recursion-schemes, servant, text
Files
- CHANGELOG.md +4/−0
- LICENSE +21/−0
- inferno-types.cabal +64/−0
- src/Inferno/Types/Module.hs +45/−0
- src/Inferno/Types/Syntax.hs +1466/−0
- src/Inferno/Types/Type.hs +251/−0
- src/Inferno/Types/Value.hs +90/−0
- src/Inferno/Types/VersionControl.hs +299/−0
- src/Inferno/Utils/Prettyprinter.hs +22/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Revision History for inferno-types++## 0.1.0.0 -- 2022-11-28+* Prepare for OSS release
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Plow Technologies++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ inferno-types.cabal view
@@ -0,0 +1,64 @@+cabal-version: >=1.10+name: inferno-types+version: 0.1.0.0+synopsis: Core types for Inferno+description: Core types for the Inferno language+category: DSL,Scripting+homepage: https://github.com/plow-technologies/inferno.git#readme+bug-reports: https://github.com/plow-technologies/inferno.git/issues+copyright: Plow-Technologies LLC+license: MIT+license-file: LICENSE+author: Sam Balco+maintainer: info@plowtech.net+build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/plow-technologies/inferno.git++library+ exposed-modules:+ Inferno.Types.Module+ , Inferno.Types.Syntax+ , Inferno.Types.Type+ , Inferno.Types.Value+ , Inferno.Types.VersionControl+ , Inferno.Utils.Prettyprinter+ hs-source-dirs:+ src+ ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ build-depends:+ aeson >= 2.1.1 && < 2.2+ , base >= 4.13 && < 4.17+ , base64-bytestring >= 1.2.1 && < 1.3+ , bifunctors >= 5.5.13 && < 5.6+ , bytestring >= 0.10.10 && < 0.12+ , cereal >= 0.5.8 && < 0.6+ , containers >= 0.6.2 && < 0.7+ , cryptonite >= 0.30 && < 0.31+ , deepseq >= 1.4.4 && < 1.5+ , hashable >= 1.4.1 && < 1.5+ , megaparsec >= 9.2.1 && < 9.3+ , memory >= 0.18.0 && < 0.19+ , mtl >= 2.2.2 && < 2.3+ , prettyprinter >= 1.7.1 && < 1.8+ , QuickCheck >= 2.14.2 && < 2.15+ , quickcheck-arbitrary-adt >= 0.3.1 && < 0.4+ , quickcheck-instances >= 0.3.28 && < 0.4+ , recursion-schemes >= 5.2.2 && < 5.3+ , servant >= 0.19 && < 0.20+ , text >= 2.0.1 && < 2.1+ default-language: Haskell2010+ default-extensions:+ DeriveDataTypeable+ , DeriveFunctor+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , TupleSections+ , RecordWildCards
+ src/Inferno/Types/Module.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}++module Inferno.Types.Module where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Map as Map+import qualified Data.Set as Set+import GHC.Generics (Generic)+import Inferno.Types.Syntax (Expr, ModuleName, OpsTable)+import Inferno.Types.Type (Namespace, TCScheme, TypeClass, TypeMetadata)+import Inferno.Types.VersionControl (VCHashUpdate, VCObjectHash)++data Module objs = Module+ { moduleName :: ModuleName,+ moduleOpsTable :: OpsTable,+ moduleTypeClasses :: Set.Set TypeClass,+ moduleObjects :: objs+ }+ deriving (Eq, Generic)+ deriving anyclass (VCHashUpdate, ToJSON, FromJSON)++newtype BuiltinModuleHash = BuiltinModuleHash ModuleName+ deriving stock (Generic)+ deriving anyclass (VCHashUpdate)++newtype BuiltinFunHash = BuiltinFunHash (Expr () (), TCScheme)+ deriving stock (Generic)+ deriving anyclass (VCHashUpdate)++newtype BuiltinEnumHash = BuiltinEnumHash TCScheme+ deriving stock (Generic)+ deriving anyclass (VCHashUpdate)++type PinnedModule m =+ Module (Map.Map Namespace VCObjectHash, Map.Map VCObjectHash (TypeMetadata TCScheme), m)++pinnedModuleNameToHash :: PinnedModule m -> Map.Map Namespace VCObjectHash+pinnedModuleNameToHash Module {moduleObjects = (hashes, _, _)} = hashes++pinnedModuleHashToTy :: PinnedModule m -> Map.Map VCObjectHash (TypeMetadata TCScheme)+pinnedModuleHashToTy Module {moduleObjects = (_, tys, _)} = tys++pinnedModuleTerms :: PinnedModule m -> m+pinnedModuleTerms Module {moduleObjects = (_, _, trms)} = trms
+ src/Inferno/Types/Syntax.hs view
@@ -0,0 +1,1466 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Inferno.Types.Syntax+ ( Ident (..),+ ExtIdent (..),+ ImplExpl (..),+ Import (..),+ ModuleName (..),+ InfixFixity (..),+ Fixity (..),+ Comment (..),+ IStr (..),+ OpsTable,+ SomeIStr (..),+ toEitherList,+ fromEitherList,+ Lit (..),+ Pat (..),+ PatF (..),+ TV (..),+ BaseType (..),+ InfernoType (..),+ Expr+ ( ..,+ Var_,+ OpVar_,+ TypeRep_,+ Enum_,+ App_,+ Lam_,+ Let_,+ Lit_,+ InterpolatedString_,+ If_,+ Op_,+ PreOp_,+ Tuple_,+ One_,+ Empty_,+ Assert_,+ Case_,+ Array_,+ ArrayComp_,+ Bracketed_,+ RenameModule_,+ OpenModule_+ ),+ BlockUtils (..),+ ElementPosition (..),+ TList (..),+ SigVar (..),+ SourcePos (..),+ Scoped (..),+ Dependencies (..),+ arbitraryName,+ collectArrs,+ extractArgsAndPrettyPrint,+ tListToList,+ tListFromList,+ sigVarToIdent,+ sigVarToExpr,+ patternToExpr,+ incSourceCol,+ fromScoped,+ rws,+ punctuate',+ hideInternalIdents,+ substInternalIdents,+ getIdentifierPositions,+ )+where++import Control.Applicative (liftA, liftA2, liftA3)+import Control.DeepSeq (NFData (..))+import Control.Monad (replicateM)+import Data.Aeson (FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (FromJSONKeyTextParser), ToJSON (..), ToJSONKey (..))+import Data.Aeson.Types (toJSONKeyText)+import Data.Bifunctor.TH (deriveBifunctor)+import Data.Data (Constr, Data (..), Typeable, gcast1, mkConstr, mkDataType)+import qualified Data.Data as Data+import Data.Functor.Foldable (ana, cata, project)+import Data.Functor.Foldable.TH (makeBaseFunctor)+import Data.Hashable (Hashable (hashWithSalt))+import Data.Int (Int64)+import qualified Data.IntMap as IntMap+import Data.List.NonEmpty (NonEmpty ((:|)), toList)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Serialize (Serialize)+import qualified Data.Serialize as Serialize+import qualified Data.Set as Set+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Word (Word64)+import GHC.Generics (Generic)+import Inferno.Utils.Prettyprinter (renderPretty)+import Numeric (showHex)+import Prettyprinter+ ( Doc,+ Pretty (pretty),+ align,+ concatWith,+ enclose,+ flatAlt,+ group,+ hardline,+ indent,+ lbracket,+ line,+ line',+ lparen,+ nest,+ rbracket,+ rparen,+ sep,+ vsep,+ (<+>),+ )+import qualified Prettyprinter.Internal as Pretty+import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf, oneof, recursivelyShrink, shrinkNothing, sized, suchThat)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary)+import Test.QuickCheck.Instances.Text ()+import Text.Megaparsec (Pos, SourcePos (..), mkPos, unPos)+import Text.Read (readMaybe)++newtype TV = TV {unTV :: Int}+ deriving stock (Eq, Ord, Show, Data, Generic)+ deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey, NFData, Hashable, Arbitrary, Serialize)+ deriving anyclass (ToADTArbitrary)++data BaseType+ = TInt+ | TDouble+ | TWord16+ | TWord32+ | TWord64+ | TText+ | TTime+ | TTimeDiff+ | TResolution+ | TEnum Text (Set.Set Ident)+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON, NFData, ToADTArbitrary)++instance Arbitrary BaseType where+ shrink = shrinkNothing+ arbitrary =+ oneof $+ (TEnum <$> (Text.pack <$> arbitrary) <*> (Set.fromList <$> listOf arbitrary))+ : ( map+ pure+ [ TInt,+ TDouble,+ TWord16,+ TWord32,+ TWord64,+ TText,+ TTime,+ TTimeDiff,+ TResolution+ ]+ )++instance Serialize BaseType where+ get =+ Serialize.getInt8 >>= \case+ 0 -> pure TInt+ 1 -> pure TDouble+ 2 -> pure TWord16+ 3 -> pure TWord32+ 4 -> pure TWord64+ 5 -> pure TText+ 6 -> pure TTime+ 7 -> pure TTimeDiff+ 8 -> pure TResolution+ _ -> do+ nm <- Serialize.get+ ids <- Serialize.get+ pure $ TEnum (Text.decodeUtf8 nm) $ Set.fromList $ map (Ident . Text.decodeUtf8) ids++ put = \case+ TInt -> Serialize.putInt8 0+ TDouble -> Serialize.putInt8 1+ TWord16 -> Serialize.putInt8 2+ TWord32 -> Serialize.putInt8 3+ TWord64 -> Serialize.putInt8 4+ TText -> Serialize.putInt8 5+ TTime -> Serialize.putInt8 6+ TTimeDiff -> Serialize.putInt8 7+ TResolution -> Serialize.putInt8 8+ TEnum nm ids -> do+ Serialize.putInt8 9+ Serialize.put $ Text.encodeUtf8 nm+ Serialize.put $ map (Text.encodeUtf8 . unIdent) $ Set.toList ids++instance Hashable BaseType where+ hashWithSalt s TInt = hashWithSalt s (1 :: Int)+ hashWithSalt s TDouble = hashWithSalt s (2 :: Int)+ hashWithSalt s TWord16 = hashWithSalt s (3 :: Int)+ hashWithSalt s TWord32 = hashWithSalt s (4 :: Int)+ hashWithSalt s TWord64 = hashWithSalt s (5 :: Int)+ hashWithSalt s TText = hashWithSalt s (6 :: Int)+ hashWithSalt s TTime = hashWithSalt s (7 :: Int)+ hashWithSalt s TTimeDiff = hashWithSalt s (8 :: Int)+ hashWithSalt s TResolution = hashWithSalt s (9 :: Int)+ hashWithSalt s (TEnum nm cs) = hashWithSalt s (10 :: Int, nm, Set.toList cs)++data InfernoType+ = TVar TV+ | TBase BaseType+ | TArr InfernoType InfernoType+ | TArray InfernoType+ | TSeries InfernoType+ | TOptional InfernoType+ | TTuple (TList InfernoType)+ | TRep InfernoType+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON, NFData, Hashable, ToADTArbitrary)+ deriving anyclass (Serialize)++instance Arbitrary InfernoType where+ shrink = recursivelyShrink+ arbitrary = sized arbitrarySized+ where+ arbitraryVar =+ TVar <$> arbitrary++ arbitraryArr n =+ TArr+ <$> (arbitrarySized $ n `div` 3)+ <*> (arbitrarySized $ n `div` 3)++ arbitraryTTuple n =+ oneof+ [ pure $ TTuple TNil,+ TTuple <$> (TCons <$> (arbitrarySized $ n `div` 3) <*> (arbitrarySized $ n `div` 3) <*> listOf (arbitrarySized $ n `div` 3))+ ]++ arbitraryBase = TBase <$> arbitrary++ arbitraryRest n = do+ constr <- elements [TArray, TSeries, TOptional, TRep]+ constr <$> (arbitrarySized $ n `div` 3)++ arbitrarySized 0 =+ oneof+ [ arbitraryVar,+ arbitraryBase+ ]+ arbitrarySized n =+ oneof+ [ arbitraryVar,+ arbitraryBase,+ arbitraryArr n,+ arbitraryTTuple n,+ arbitraryRest n+ ]++punctuate' :: Doc ann -> [Doc ann] -> [Doc ann]+punctuate' _ [] = []+punctuate' _ [d] = [d]+punctuate' p (d : ds) = (d <+> p) : punctuate' p ds++collectArrs :: InfernoType -> [InfernoType]+collectArrs (TArr ty1 ty2) = ty1 : collectArrs ty2+collectArrs t = [t]++letters :: [Text]+letters = map Text.pack $ [1 ..] >>= flip replicateM ['a' .. 'z']++instance Pretty TV where+ pretty (TV i) = "'" <> pretty (letters !! i)++instance Pretty BaseType where+ pretty = \case+ TInt -> "int"+ TDouble -> "double"+ TWord16 -> "word16"+ TWord32 -> "word32"+ TWord64 -> "word64"+ TText -> "text"+ TTime -> "time"+ TTimeDiff -> "timeDiff"+ TResolution -> "resolution"+ TEnum t _ -> pretty t++instance Pretty InfernoType where+ pretty = \case+ TVar v -> pretty v+ TBase b -> pretty b+ t@(TArr _ _) ->+ let prettyType = align . sep . punctuate' "→"+ in prettyType $+ map (\t' -> case t' of TArr _ _ -> enclose lparen rparen $ pretty t'; _ -> pretty t') $+ collectArrs t+ TArray ty@(TVar _) -> "array of" <+> align (pretty ty)+ TArray ty@(TBase _) -> "array of" <+> align (pretty ty)+ TArray ty@(TTuple _) -> "array of" <+> align (pretty ty)+ TArray ty -> "array of" <+> align (enclose lparen rparen $ pretty ty)+ TSeries ty@(TVar _) -> "series of" <+> align (pretty ty)+ TSeries ty@(TBase _) -> "series of" <+> align (pretty ty)+ TSeries ty@(TTuple _) -> "series of" <+> align (pretty ty)+ TSeries ty -> "series of" <+> align (enclose lparen rparen $ pretty ty)+ TOptional ty@(TVar _) -> "option of" <+> align (pretty ty)+ TOptional ty@(TBase _) -> "option of" <+> align (pretty ty)+ TOptional ty@(TTuple _) -> "option of" <+> align (pretty ty)+ TOptional ty -> "option of" <+> align (enclose lparen rparen $ pretty ty)+ TTuple tys -> Pretty.tupled (map pretty $ tListToList tys)+ TRep ty@(TVar _) -> "rep of" <+> align (pretty ty)+ TRep ty@(TBase _) -> "rep of" <+> align (pretty ty)+ TRep ty@(TTuple _) -> "rep of" <+> align (pretty ty)+ TRep ty -> "rep of" <+> align (enclose lparen rparen $ pretty ty)++incSourceCol :: SourcePos -> Int -> SourcePos+incSourceCol pos 0 = pos+incSourceCol (SourcePos n l c) i = SourcePos n l (c <> mkPos i)++rws :: [Text] -- list of reserved words+rws = ["if", "then", "else", "let", "module", "in", "match", "with", "Some", "None", "assert", "fun", "infixr", "infixl", "infix", "enum", "open"]++newtype Ident = Ident {unIdent :: Text}+ deriving stock (Eq, Ord, Show, Data, Generic)+ deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey, IsString, NFData, Hashable)+ deriving anyclass (ToADTArbitrary)++arbitraryName :: Gen Text+arbitraryName =+ ( (\a as -> Text.pack $ a : as)+ <$> (elements ['a' .. 'z'])+ <*> (listOf $ elements $ ['0' .. '9'] ++ ['a' .. 'z'] ++ ['_'])+ )+ `suchThat` (\i -> not $ i `elem` rws)++instance Arbitrary Ident where+ shrink = shrinkNothing+ arbitrary = Ident <$> arbitraryName++newtype ModuleName = ModuleName {unModuleName :: Text}+ deriving stock (Eq, Ord, Show, Data, Generic)+ deriving newtype (ToJSON, FromJSON, IsString)+ deriving anyclass (ToADTArbitrary)++instance Arbitrary ModuleName where+ shrink = shrinkNothing+ arbitrary = ModuleName <$> arbitraryName++class ElementPosition a where+ elementPosition :: SourcePos -> a -> (SourcePos, SourcePos)++instance ElementPosition Ident where+ elementPosition pos (Ident a) = (pos, incSourceCol pos $ Text.length a)++instance ElementPosition ModuleName where+ elementPosition pos (ModuleName a) = (pos, incSourceCol pos $ Text.length a)++instance ElementPosition (Maybe Ident) where+ elementPosition pos = \case+ Just i -> elementPosition pos i+ Nothing -> (pos, incSourceCol pos 1)++-- | An extended identifier; either an internal (e.g., var$4) or a regular variable+newtype ExtIdent = ExtIdent (Either Int Text)+ deriving (Show, Eq, Ord, Data, Generic)+ deriving newtype (ToJSON, FromJSON)++instance Arbitrary ExtIdent where+ shrink = shrinkNothing+ arbitrary =+ ExtIdent <$> oneof [Left <$> (arbitrary `suchThat` ((<) 0)), Right <$> arbitraryName]++instance ToJSONKey ExtIdent where+ toJSONKey = toJSONKeyText $ \case+ ExtIdent (Left i) -> "var$" <> (Text.pack $ show i)+ ExtIdent (Right k) -> "reg$" <> k++instance FromJSONKey ExtIdent where+ fromJSONKey = FromJSONKeyTextParser $ \t ->+ case Text.take 4 t of+ "var$" -> case readMaybe $ Text.unpack $ Text.drop 4 t of+ Just i -> pure $ ExtIdent $ Left i+ Nothing -> fail "Could not read internal var"+ "reg$" -> pure $ ExtIdent $ Right $ Text.drop 4 t+ _ -> fail "Invalid ExtIdent key"++data ImplExpl = Impl ExtIdent | Expl ExtIdent+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++instance Pretty ExtIdent where+ pretty (ExtIdent i) = case i of+ Left n -> "var$" <> pretty n+ Right x -> pretty x++instance Pretty ImplExpl where+ pretty = \case+ Impl a -> "?" <> pretty a+ Expl a -> pretty a++instance ElementPosition ImplExpl where+ elementPosition pos = \case+ Impl (ExtIdent (Left _)) -> (pos, pos)+ Impl (ExtIdent (Right a)) -> (pos, incSourceCol pos $ Text.length a + 1)+ Expl (ExtIdent (Left _)) -> (pos, pos)+ Expl (ExtIdent (Right a)) -> (pos, incSourceCol pos $ Text.length a)++data Fixity = InfixOp InfixFixity | PrefixOp deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++data InfixFixity = NoFix | LeftFix | RightFix deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++instance ToJSON Pos where+ toJSON = toJSON . unPos++deriving instance ToJSON SourcePos++instance FromJSON Pos where+ parseJSON = fmap mkPos . parseJSON++deriving instance FromJSON SourcePos++data Comment pos+ = LineComment pos Text pos+ | BlockComment pos Text pos+ deriving (Show, Eq, Ord, Data, Generic, Functor, Foldable, ToJSON, FromJSON)++instance Pretty (Comment a) where+ pretty = \case+ LineComment _ str _ -> ("//" <+> pretty str)+ BlockComment _ str _ -> encloseComment $ map pretty $ Text.splitOn "\n" $ Text.strip str+ where+ encloseComment ds = case ds of+ [] -> "/* */"+ [d] -> "/*" <+> d <+> "*/"+ _ -> hardVcat (zipWith (<>) ("/* " : repeat mempty) ds) <> " */"++ hardVcat :: [Doc ann] -> Doc ann+ hardVcat = concatWith (\x y -> x <> hardline <> y)++data Lit+ = LInt Int64+ | LDouble Double+ | LText Text+ | LHex Word64+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++instance Pretty Lit where+ pretty = \case+ LInt i -> if i < 0 then "(" <> pretty i <> ")" else pretty i+ LDouble d -> if d < 0 then "(" <> pretty d <> ")" else pretty d+ LText t -> pretty $ show t+ LHex w -> "0x" <> (pretty $ showHex w "")++instance ElementPosition Lit where+ elementPosition pos l = (pos, incSourceCol pos $ length $ show $ pretty l)++data TList a = TNil | TCons a a [a]+ deriving (Show, Eq, Ord, Functor, Foldable, Data, Generic, ToJSON, FromJSON, NFData, Hashable, ToADTArbitrary)+ deriving anyclass (Serialize)++instance Arbitrary a => Arbitrary (TList a) where+ arbitrary =+ oneof+ [ pure TNil,+ TCons <$> arbitrary <*> arbitrary <*> listOf arbitrary+ ]++instance Traversable TList where+ {-# INLINE traverse #-} -- so that traverse can fuse+ traverse f = \case+ TNil -> pure TNil+ TCons x y zs -> liftA3 TCons (f x) (f y) (traverse f zs)++tListToList :: TList a -> [a]+tListToList = \case+ TNil -> []+ TCons a b cs -> a : b : cs++tListFromList :: [a] -> TList a+tListFromList = \case+ [] -> TNil+ (a : b : cs) -> TCons a b cs+ _ -> error "undefined TList"++data IStr (f :: Bool) e where+ ISEmpty :: IStr 'True e+ ISStr :: Text -> IStr 'True e -> IStr 'False e+ ISExpr :: Typeable f => e -> IStr f e -> IStr 'True e++instance (Typeable f, Data e) => Data (IStr f e) where+ gfoldl _ z ISEmpty = z ISEmpty+ gfoldl k z (ISStr s xs) = z ISStr `k` s `k` xs+ gfoldl k z (ISExpr e xs) = z ISExpr `k` e `k` xs++ gunfold _ _ _ =+ error $+ "Cannot derive a gunfold instance without unsafeCoerce.\n"+ <> "If this function is needed, try uncommenting the lines below. However, this definition might not be correct."++ -- where+ -- gunfold' :: forall c. (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (IStr f e)+ -- gunfold' k z c = case constrIndex c of+ -- 1 -> unsafeCoerce $ z ISEmpty+ -- 2 -> unsafeCoerce $ k (k (z ISStr) :: Typeable f => c (IStr 'True e -> IStr 'False e))+ -- _ -> unsafeCoerce $ k (k (z ISExpr) :: Typeable f => c (IStr f e -> IStr 'True e))++ toConstr ISEmpty = con_ISEmpty+ toConstr (ISStr _ _) = con_ISStr+ toConstr (ISExpr _ _) = con_ISExpr++ dataTypeOf _ = ty_IStr+ dataCast1 f = gcast1 f++con_ISEmpty, con_ISStr, con_ISExpr :: Constr+con_ISEmpty = mkConstr ty_IStr "ISEmpty" [] Data.Prefix+con_ISStr = mkConstr ty_IStr "ISStr" [] Data.Prefix+con_ISExpr = mkConstr ty_IStr "ISExpr" [] Data.Prefix++ty_IStr :: Data.DataType+ty_IStr = mkDataType "Inferno.Syntax.IStr" [con_ISEmpty, con_ISStr, con_ISExpr]++deriving instance Show e => Show (IStr f e)++deriving instance Functor (IStr f)++deriving instance Foldable (IStr f)++instance Traversable (IStr f) where+ {-# INLINE traverse #-} -- so that traverse can fuse+ traverse f = \case+ ISEmpty -> pure ISEmpty+ ISStr s xs -> liftA (ISStr s) (traverse f xs)+ ISExpr e xs -> liftA2 ISExpr (f e) (traverse f xs)++data SomeIStr e = forall f. Typeable f => SomeIStr (IStr f e)++instance Data e => Data (SomeIStr e) where+ gfoldl k z (SomeIStr xs) = z SomeIStr `k` xs++ gunfold _ _ _ =+ error $+ "Cannot derive a gunfold instance without unsafeCoerce.\n"+ <> "If this function is needed, try uncommenting the lines below. However, this definition might not be correct."++ -- where+ -- gunfold' :: forall c. (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (SomeIStr e)+ -- gunfold' k z _ = k (z SomeIStr :: c (IStr 'False e -> SomeIStr e))++ toConstr _ = con_SomeIStr+ dataTypeOf _ = ty_SomeIStr+ dataCast1 f = gcast1 f++con_SomeIStr :: Constr+con_SomeIStr = mkConstr ty_SomeIStr "SomeIStr" [] Data.Prefix++ty_SomeIStr :: Data.DataType+ty_SomeIStr = mkDataType "Inferno.Syntax.SomeIStr" [con_SomeIStr]++deriving instance Show e => Show (SomeIStr e)++instance Eq e => Eq (SomeIStr e) where+ (SomeIStr ISEmpty) == (SomeIStr ISEmpty) = True+ (SomeIStr (ISStr s1 xs)) == (SomeIStr (ISStr s2 ys)) =+ (s1 == s2) && (SomeIStr xs) == (SomeIStr ys)+ (SomeIStr (ISExpr e1 xs)) == (SomeIStr (ISExpr e2 ys)) =+ (e1 == e2) && (SomeIStr xs) == (SomeIStr ys)+ _ == _ = False++instance Ord e => Ord (SomeIStr e) where+ compare (SomeIStr ISEmpty) (SomeIStr ISEmpty) = EQ+ compare (SomeIStr ISEmpty) _ = LT+ compare _ (SomeIStr ISEmpty) = GT+ compare (SomeIStr (ISStr _ _)) (SomeIStr (ISExpr _ _)) = LT+ compare (SomeIStr (ISExpr _ _)) (SomeIStr (ISStr _ _)) = GT+ compare (SomeIStr (ISStr s xs)) (SomeIStr (ISStr t ys)) = case compare s t of+ EQ -> compare (SomeIStr xs) (SomeIStr ys)+ other -> other+ compare (SomeIStr (ISExpr e xs)) (SomeIStr (ISExpr f ys)) = case compare e f of+ EQ -> compare (SomeIStr xs) (SomeIStr ys)+ other -> other++deriving instance Functor SomeIStr++deriving instance Foldable SomeIStr++toEitherList :: SomeIStr e -> [Either Text e]+toEitherList = \case+ SomeIStr ISEmpty -> []+ SomeIStr (ISStr s ys) -> Left s : toEitherList (SomeIStr ys)+ SomeIStr (ISExpr e ys) -> Right e : toEitherList (SomeIStr ys)++fromEitherList :: [Either Text e] -> SomeIStr e+fromEitherList = \case+ [] -> SomeIStr (ISEmpty :: IStr 'True e)+ Left s : xs -> case fromEitherList xs of+ SomeIStr ISEmpty -> SomeIStr $ ISStr s ISEmpty+ SomeIStr (ISStr s' xs') -> SomeIStr $ ISStr (s <> s') xs'+ SomeIStr rest@(ISExpr _ _) -> SomeIStr $ ISStr s rest+ Right e : xs -> case fromEitherList xs of+ SomeIStr rest -> SomeIStr $ ISExpr e rest++instance FromJSON e => FromJSON (SomeIStr e) where+ parseJSON = fmap fromEitherList . parseJSON++instance ToJSON e => ToJSON (SomeIStr e) where+ toJSON = toJSON . toEitherList++instance Traversable SomeIStr where+ {-# INLINE traverse #-} -- so that traverse can fuse+ traverse f = \case+ SomeIStr (ISEmpty :: IStr f a) -> pure $ SomeIStr (ISEmpty :: IStr f b)+ SomeIStr (ISStr s xs) -> do+ res <- traverse f xs+ pure $ case res of+ ISEmpty -> SomeIStr $ ISStr s ISEmpty+ rest@(ISExpr _ _) -> SomeIStr $ ISStr s rest+ SomeIStr (ISExpr e xs) -> do+ e' <- f e+ res <- traverse f xs+ pure $ SomeIStr $ ISExpr e' res++data Import pos+ = IVar pos Ident+ | IOpVar pos Ident+ | IEnum+ pos -- position of `enum`+ pos -- position of ident+ Ident+ | ICommentAbove (Comment pos) (Import pos)+ | ICommentAfter (Import pos) (Comment pos)+ | ICommentBelow (Import pos) (Comment pos)+ deriving (Show, Eq, Ord, Functor, Foldable, Generic, Data, ToJSON, FromJSON)++makeBaseFunctor ''Import++data Scoped a = LocalScope | Scope a+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Data, Generic, ToJSON, FromJSON)++fromScoped :: a -> Scoped a -> a+fromScoped d = \case+ Scope a -> a+ LocalScope -> d++data Expr hash pos+ = Var+ pos+ hash+ (Scoped ModuleName)+ ImplExpl+ | OpVar pos hash (Scoped ModuleName) Ident -- infix ops like `+` used as prefix, i.e. `(+)`+ | TypeRep pos InfernoType+ | Enum pos hash (Scoped ModuleName) Ident+ | App (Expr hash pos) (Expr hash pos)+ | Lam+ pos -- position of `fun`+ ( NonEmpty+ ( pos, -- position of variable,+ Maybe ExtIdent+ )+ )+ pos -- position of `->`+ (Expr hash pos)+ | Let+ pos -- position of `let`+ pos -- position of variable+ ImplExpl+ pos -- position of `=`+ (Expr hash pos)+ pos -- position of `in`+ (Expr hash pos)+ | Lit pos Lit+ | InterpolatedString+ pos -- position of string start+ (SomeIStr (pos, Expr hash pos, pos))+ pos -- position of string end+ | If+ pos -- position of `if`+ (Expr hash pos)+ pos -- position of then`+ (Expr hash pos)+ pos -- position of `else`+ (Expr hash pos)+ | Op+ (Expr hash pos)+ pos -- position of operator+ hash+ (Int, InfixFixity) -- level and fixity of the operaror+ (Scoped ModuleName)+ Ident+ (Expr hash pos)+ | PreOp+ pos -- position of operator+ hash+ Int -- level of the operaror+ (Scoped ModuleName)+ Ident+ (Expr hash pos)+ | Tuple+ pos -- position of `(`+ (TList (Expr hash pos, Maybe pos))+ pos -- position of `)`+ -- NOTE: the frontend syntax is Some/None but internally we use one/empty for legacy reasons+ | One+ pos -- position of `Some`+ (Expr hash pos)+ | Empty pos -- position of `None`+ | Assert+ pos -- position of `assert`+ (Expr hash pos)+ pos -- position of `in`+ (Expr hash pos)+ | Case+ pos -- position of `match`+ (Expr hash pos)+ pos -- position of `{`+ ( NonEmpty+ ( pos, -- position of `|`+ Pat hash pos,+ pos, -- position of `->`+ Expr hash pos+ )+ )+ pos -- position of `}`+ | Array+ pos -- position of `[`+ [ ( Expr hash pos,+ Maybe pos -- position of `,`+ )+ ]+ pos -- position of `]`+ | ArrayComp+ pos -- position of `[`+ (Expr hash pos)+ pos -- position of `|`+ ( NonEmpty+ ( pos, -- position of identifier+ Ident,+ pos, -- position of `<-`+ Expr hash pos,+ Maybe pos -- position of `,`+ )+ )+ ( Maybe+ ( pos, -- position of `if`+ Expr hash pos+ )+ )+ pos -- position of `]`+ | CommentAbove+ (Comment pos)+ (Expr hash pos)+ | CommentAfter+ (Expr hash pos)+ (Comment pos)+ | CommentBelow+ (Expr hash pos)+ (Comment pos)+ | Bracketed pos (Expr hash pos) pos+ | RenameModule+ pos -- pos of new name+ ModuleName+ pos -- pos of old name+ ModuleName+ pos -- pos of `in`+ (Expr hash pos)+ | OpenModule+ pos+ hash+ ModuleName+ [(Import pos, Maybe pos)]+ pos -- pos of `in`+ (Expr hash pos)+ deriving (Show, Eq, Ord, Functor, Foldable, Generic, Data, ToJSON, FromJSON)++{-# COMPLETE+ Var_,+ OpVar_,+ TypeRep_,+ Enum_,+ App_,+ Lam_,+ Let_,+ Lit_,+ InterpolatedString_,+ If_,+ Op_,+ PreOp_,+ Tuple_,+ One_,+ Empty_,+ Assert_,+ Case_,+ Array_,+ ArrayComp_,+ CommentAbove,+ CommentAfter,+ CommentBelow,+ Bracketed_,+ RenameModule_,+ OpenModule_+ #-}++pattern Var_ :: forall hash pos. hash -> Scoped ModuleName -> ImplExpl -> Expr hash pos+pattern Var_ h ns x <- Var _ h ns x++pattern OpVar_ :: forall hash pos. hash -> Scoped ModuleName -> Ident -> Expr hash pos+pattern OpVar_ h ns x <- OpVar _ h ns x++pattern TypeRep_ :: forall hash pos. InfernoType -> Expr hash pos+pattern TypeRep_ ty <- TypeRep _ ty++pattern Enum_ :: forall hash pos. hash -> Scoped ModuleName -> Ident -> Expr hash pos+pattern Enum_ h ns x <- Enum _ h ns x++pattern App_ :: forall hash pos. Expr hash pos -> Expr hash pos -> Expr hash pos+pattern App_ e1 e2 <- App e1 e2++pattern Lam_ :: forall hash pos. NonEmpty (pos, Maybe ExtIdent) -> Expr hash pos -> Expr hash pos+pattern Lam_ xs e <- Lam _ xs _ e++pattern Let_ :: forall hash pos. ImplExpl -> Expr hash pos -> Expr hash pos -> Expr hash pos+pattern Let_ x e1 e2 <- Let _ _ x _ e1 _ e2++pattern Lit_ :: forall hash pos. Lit -> Expr hash pos+pattern Lit_ l <- Lit _ l++pattern InterpolatedString_ :: forall hash pos. SomeIStr (pos, Expr hash pos, pos) -> Expr hash pos+pattern InterpolatedString_ xs <- InterpolatedString _ xs _++pattern If_ :: forall hash pos. Expr hash pos -> Expr hash pos -> Expr hash pos -> Expr hash pos+pattern If_ c t f <- If _ c _ t _ f++pattern Op_ :: forall hash pos. Expr hash pos -> hash -> Scoped ModuleName -> Ident -> Expr hash pos -> Expr hash pos+pattern Op_ e1 h ns op e2 <- Op e1 _ h _ ns op e2++pattern PreOp_ :: forall hash pos. hash -> Scoped ModuleName -> Ident -> Expr hash pos -> Expr hash pos+pattern PreOp_ h ns op e <- PreOp _ h _ ns op e++pattern Tuple_ :: forall hash pos. TList (Expr hash pos, Maybe pos) -> Expr hash pos+pattern Tuple_ xs <- Tuple _ xs _++pattern One_ :: forall hash pos. Expr hash pos -> Expr hash pos+pattern One_ e <- One _ e++pattern Empty_ :: forall hash pos. Expr hash pos+pattern Empty_ <- Empty _++pattern Assert_ :: forall hash pos. Expr hash pos -> Expr hash pos -> Expr hash pos+pattern Assert_ c e <- Assert _ c _ e++pattern Case_ :: forall hash pos. Expr hash pos -> NonEmpty (pos, Pat hash pos, pos, Expr hash pos) -> Expr hash pos+pattern Case_ e xs <- Case _ e _ xs _++pattern Array_ :: forall hash pos. [(Expr hash pos, Maybe pos)] -> Expr hash pos+pattern Array_ xs <- Array _ xs _++pattern ArrayComp_ ::+ forall hash pos.+ Expr hash pos ->+ NonEmpty (pos, Ident, pos, Expr hash pos, Maybe pos) ->+ Maybe (pos, Expr hash pos) ->+ Expr hash pos+pattern ArrayComp_ e xs c <- ArrayComp _ e _ xs c _++pattern Bracketed_ :: forall hash pos. Expr hash pos -> Expr hash pos+pattern Bracketed_ e <- Bracketed _ e _++pattern RenameModule_ :: forall hash pos. ModuleName -> ModuleName -> Expr hash pos -> Expr hash pos+pattern RenameModule_ n1 n2 e <- RenameModule _ n1 _ n2 _ e++pattern OpenModule_ :: forall hash pos. ModuleName -> [(Import pos, Maybe pos)] -> Expr hash pos -> Expr hash pos+pattern OpenModule_ n1 ns e <- OpenModule _ _ n1 ns _ e++data Pat hash pos+ = PVar pos (Maybe Ident)+ | PEnum pos hash (Scoped ModuleName) Ident+ | PLit pos Lit+ | POne pos (Pat hash pos)+ | PEmpty pos+ | PTuple pos (TList (Pat hash pos, Maybe pos)) pos+ | PCommentAbove+ (Comment pos)+ (Pat hash pos)+ | PCommentAfter+ (Pat hash pos)+ (Comment pos)+ | PCommentBelow+ (Pat hash pos)+ (Comment pos)+ deriving (Show, Eq, Ord, Functor, Foldable, Data, Generic, ToJSON, FromJSON)++makeBaseFunctor ''Pat++makeBaseFunctor ''Expr++deriveBifunctor ''Pat++deriveBifunctor ''Expr++patternToExpr :: Pat () () -> Expr () ()+patternToExpr = \case+ PVar _ Nothing -> Var () () LocalScope $ Expl $ ExtIdent $ Right "_"+ PVar _ (Just (Ident i)) -> Var () () LocalScope $ Expl $ ExtIdent $ Right i+ PEnum _ _ modNm i -> Enum () () modNm i+ PLit _ l -> Lit () l+ POne _ p -> One () $ patternToExpr p+ PEmpty _ -> Empty ()+ PTuple _ ps _ -> Tuple () (fmap (\(pat, pos) -> (patternToExpr pat, pos)) ps) ()+ PCommentAbove c p -> CommentAbove c $ patternToExpr p+ PCommentAfter p c -> CommentAfter (patternToExpr p) c+ PCommentBelow p c -> CommentBelow (patternToExpr p) c++getIdentifierPositions :: Ident -> Expr a SourcePos -> [(SourcePos, SourcePos)]+getIdentifierPositions (Ident i) = cata go+ where+ go :: ExprF a SourcePos [(SourcePos, SourcePos)] -> [(SourcePos, SourcePos)]+ go = \case+ VarF pos _ _ v@(Expl (ExtIdent (Right a))) -> if i == a then let (sPos, ePos) = elementPosition pos v in [(sPos, ePos)] else []+ rest -> foldr (++) [] rest++class BlockUtils f where+ blockPosition :: f SourcePos -> (SourcePos, SourcePos)+ removeComments :: f pos -> f pos+ hasLeadingComment :: f pos -> Bool+ hasTrailingComment :: f pos -> Bool+ renameModule :: Scoped ModuleName -> f pos -> f pos++instance BlockUtils Comment where+ blockPosition = \case+ LineComment s _ e -> (s, e)+ BlockComment s _ e -> (s, e)++ removeComments = id+ hasLeadingComment _ = True+ hasTrailingComment _ = True+ renameModule _ = id++instance BlockUtils Import where+ blockPosition p = cata go p+ where+ go = \case+ IVarF pos v -> elementPosition pos v+ IOpVarF pos (Ident i) -> (pos, incSourceCol pos $ Text.length i + 2)+ IEnumF pos1 pos2 (Ident i) -> (pos1, incSourceCol pos2 $ Text.length i)+ ICommentAboveF c (_, pos2) -> let (pos1, _) = blockPosition c in (pos1, pos2)+ ICommentAfterF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)+ ICommentBelowF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)++ removeComments = ana $ \case+ ICommentAbove _ p -> project $ removeComments p+ ICommentAfter p _ -> project $ removeComments p+ ICommentBelow p _ -> project $ removeComments p+ other -> project other+ renameModule _ = id++ hasLeadingComment = head . cata go+ where+ go = \case+ ICommentAboveF _ _ -> [True]+ rest -> foldr (++) [False] rest++ hasTrailingComment = last . cata go+ where+ go = \case+ ICommentAfterF _ _ -> [True]+ ICommentBelowF _ _ -> [True]+ rest -> foldl (++) [False] rest++instance BlockUtils (Pat hash) where+ blockPosition p = cata go p+ where+ go :: PatF hash SourcePos (SourcePos, SourcePos) -> (SourcePos, SourcePos)+ go = \case+ PVarF pos v -> elementPosition pos v+ PEnumF pos _ ns (Ident i) -> (pos, incSourceCol pos $ Text.length i + 1 + (fromScoped 0 $ (+ 1) . Text.length . unModuleName <$> ns))+ PLitF pos l -> elementPosition pos l+ PEmptyF pos -> (pos, incSourceCol pos 5)+ POneF pos1 (_, pos2) -> (pos1, pos2)+ PTupleF pos1 _ pos2 -> (pos1, incSourceCol pos2 1)+ PCommentAboveF c (_, pos2) -> let (pos1, _) = blockPosition c in (pos1, pos2)+ PCommentAfterF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)+ PCommentBelowF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)++ removeComments = ana $ \case+ PCommentAbove _ p -> project $ removeComments p+ PCommentAfter p _ -> project $ removeComments p+ PCommentBelow p _ -> project $ removeComments p+ other -> project other++ renameModule newNs = ana $ \case+ PEnum pos hash _ns i -> project $ PEnum pos hash newNs i+ other -> project other++ hasLeadingComment = head . cata go+ where+ go :: PatF hash pos [Bool] -> [Bool]+ go = \case+ PCommentAboveF _ _ -> [True]+ rest -> foldr (++) [False] rest++ hasTrailingComment = last . cata go+ where+ go :: PatF hash pos [Bool] -> [Bool]+ go = \case+ PCommentAfterF _ _ -> [True]+ PCommentBelowF _ _ -> [True]+ rest -> foldl (++) [False] rest++instance BlockUtils (Expr hash) where+ blockPosition e = cata go e+ where+ go :: ExprF hash SourcePos (SourcePos, SourcePos) -> (SourcePos, SourcePos)+ go = \case+ VarF pos _ ns v -> let (sPos, ePos) = elementPosition pos v in (sPos, incSourceCol ePos $ fromScoped 0 $ (+ 1) . Text.length . unModuleName <$> ns)+ OpVarF pos _ ns v -> let (sPos, ePos) = elementPosition pos v in (sPos, incSourceCol ePos $ fromScoped 2 $ (+ 3) . Text.length . unModuleName <$> ns)+ EnumF pos _ ns (Ident i) -> (pos, incSourceCol pos $ Text.length i + 1 + (fromScoped 0 $ (+ 1) . Text.length . unModuleName <$> ns))+ AppF (pos1, _) (_, pos2) -> (pos1, pos2)+ LamF pos1 _ _ (_, pos2) -> (pos1, pos2)+ LetF pos1 _ _ _ _ _ (_, pos2) -> (pos1, pos2)+ LitF pos l -> (pos, incSourceCol pos $ length $ show $ pretty l)+ InterpolatedStringF pos1 _ pos2 -> (pos1, pos2)+ IfF pos1 _ _ _ _ (_, pos2) -> (pos1, pos2)+ OpF (pos1, _) _ _ _ _ _ (_, pos2) -> (pos1, pos2)+ PreOpF pos1 _ _ _ _ (_, pos2) -> (pos1, pos2)+ TupleF pos1 _ pos2 -> (pos1, incSourceCol pos2 1)+ OneF pos1 (_, pos2) -> (pos1, pos2)+ EmptyF pos -> (pos, incSourceCol pos 5)+ AssertF pos1 _ _ (_, pos2) -> (pos1, pos2)+ CaseF pos1 _ _ _ pos2 -> (pos1, incSourceCol pos2 1)+ ArrayF pos1 _ pos2 -> (pos1, incSourceCol pos2 1)+ ArrayCompF pos1 _ _ _ _ pos2 -> (pos1, incSourceCol pos2 1)+ CommentAboveF c (_, pos2) -> let (pos1, _) = blockPosition c in (pos1, pos2)+ CommentAfterF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)+ CommentBelowF (pos1, _) c -> let (_, pos2) = blockPosition c in (pos1, pos2)+ BracketedF pos1 _ pos2 -> (pos1, pos2)+ RenameModuleF pos1 _ _ _ _ (_, pos2) -> (pos1, pos2)+ OpenModuleF pos1 _ _ _ _ (_, pos2) -> (pos1, pos2)+ TypeRepF pos _ -> (pos, pos)++ removeComments = ana $ \case+ CommentAbove _ p -> project $ removeComments p+ CommentAfter p _ -> project $ removeComments p+ CommentBelow p _ -> project $ removeComments p+ Case p1 e1 p2 xs p3 ->+ project $+ Case+ p1+ (removeComments e1)+ p2+ (fmap (\(p4, pat, p5, e2) -> (p4, removeComments pat, p5, removeComments e2)) xs)+ p3+ other -> project other++ renameModule newNs = ana $ \e -> project $ case e of+ Var pos hash _ns i -> Var pos hash newNs i+ OpVar pos hash _ns i -> OpVar pos hash newNs i+ Enum pos hash _ns i -> Enum pos hash newNs i+ Op e1 p1 hash meta _ns op e2 -> Op e1 p1 hash meta newNs op e2+ Case p1 e1 p2 xs p3 ->+ Case+ p1+ (renameModule newNs e1)+ p2+ (fmap (\(p4, pat, p5, e2) -> (p4, renameModule newNs pat, p5, renameModule newNs e2)) xs)+ p3+ other -> other+ hasLeadingComment = head . cata go+ where+ go :: ExprF hash pos [Bool] -> [Bool]+ go = \case+ CommentAboveF _ _ -> [True]+ rest -> foldr (++) [False] rest++ hasTrailingComment = last . cata go+ where+ go :: ExprF hash pos [Bool] -> [Bool]+ go = \case+ CommentAfterF _ _ -> [True]+ CommentBelowF _ _ -> [True]+ rest -> foldl (++) [False] rest++collectApps :: Expr hash pos -> [Expr hash pos]+collectApps (App x@(App _ _) y) = collectApps x ++ [y]+collectApps (App x y) = [x, y]+collectApps _ = undefined++-- | Filter out any var$n/?var$n variables and their let/lambda bindings+-- This is used when pretty printing for the front-end, as we don't want the+-- users to see these auto-generated internal variables.+hideInternalIdents :: Expr hash pos -> Expr hash pos+hideInternalIdents = ana $ \case+ App e (Var _ _ _ (Impl (ExtIdent (Left _)))) -> project $ hideInternalIdents e+ App e (Var _ _ _ (Expl (ExtIdent (Left _)))) -> project $ hideInternalIdents e+ App e (TypeRep _ _) -> project $ hideInternalIdents e+ Let _ _ (Impl (ExtIdent (Left _))) _ _ _ e -> project $ hideInternalIdents e+ Let _ _ (Expl (ExtIdent (Left _))) _ _ _ e -> project $ hideInternalIdents e+ Lam p1 xs p2 e ->+ let filteredXs = flip NonEmpty.filter xs $ \case+ (_, Just (ExtIdent (Left _))) -> False+ _ -> True+ in case filteredXs of+ [] -> project $ hideInternalIdents e+ (x' : xs') -> project $ Lam p1 (x' NonEmpty.:| xs') p2 $ hideInternalIdents e+ other -> project other++-- | Extract the arguments of a script and pretty print the script body.+-- This hides the internal variable arguments.+extractArgsAndPrettyPrint :: Expr hash pos -> ([Maybe Ident], Text)+extractArgsAndPrettyPrint expr =+ extract [] (hideInternalIdents expr)+ where+ extract args = \case+ Lam _ (x :| xs) _ e -> extract (args <> map snd (x : xs)) e+ e -> (mapMaybe extIdentToIdent args, renderPretty e)+ -- Strip the runtime type rep arguments, and convert others to Ident+ extIdentToIdent = \case+ (Just (ExtIdent (Left _))) -> Nothing+ (Just (ExtIdent (Right i))) -> Just $ Just $ Ident {unIdent = i}+ Nothing -> Just Nothing++-- | Substitute every variable occurrence of `?var$i` with `var$j`+-- if `(i, Left j)` is in in the supplied map.+-- otherwise replace `?var$i` with `@t` if (i, Right t) \in m`+substInternalIdents :: Map.Map Int (Either Int InfernoType) -> Expr hash pos -> Expr hash pos+substInternalIdents m = ana $ \case+ Var pos h ns (Impl (ExtIdent (Left i))) ->+ project $ case Map.lookup i m of+ Just (Left j) -> Var pos h ns (Expl (ExtIdent (Left j)))+ Just (Right t) -> TypeRep pos t+ Nothing -> Var pos h ns (Impl (ExtIdent (Left i)))+ other -> project other++instance Pretty (Import a) where+ pretty = \case+ IVar _ (Ident x) -> pretty x+ IOpVar _ (Ident x) -> "(" <> pretty x <> ")"+ IEnum _ _ (Ident x) -> "enum" <+> pretty x+ ICommentAbove c e -> pretty c <> hardline <> pretty e+ ICommentAfter e c -> pretty e <+> pretty c+ ICommentBelow e c -> pretty e <> line <> pretty c++instance Pretty (Pat hash a) where+ pretty = \case+ PVar _ (Just (Ident x)) -> pretty x+ PVar _ Nothing -> "_"+ PEnum _ _ ns (Ident n) -> (fromScoped mempty $ (<> ".") . pretty . unModuleName <$> ns) <> "#" <> pretty n+ PLit _ l -> pretty l+ PTuple _ TNil _ -> "()"+ PTuple _ ps _ -> group $ (flatAlt "( " "(") <> prettyTuple True (tListToList ps)+ POne _ e -> "Some" <+> align (pretty e)+ PEmpty _ -> "None"+ PCommentAbove c e -> pretty c <> hardline <> pretty e+ PCommentAfter e c -> pretty e <+> pretty c+ PCommentBelow e c -> pretty e <> line <> pretty c+ where+ prettyTuple firstElement = \case+ [] -> mempty+ [(e, _)] ->+ align (pretty e)+ <> (if hasTrailingComment e then hardline <> ")" else flatAlt " )" ")")+ (e, _) : es ->+ (if not firstElement && hasLeadingComment e then line else mempty)+ <> align (pretty e)+ <> (if hasTrailingComment e then hardline else line')+ <> ", "+ <> prettyTuple False es++instance Pretty (Expr hash pos) where+ pretty = prettyPrec False 0++prettyPrec :: Bool -> Int -> Expr hash pos -> Doc ann+prettyPrec isBracketed prec expr =+ case expr of+ Var _ _ ns x -> (fromScoped mempty $ (<> ".") . pretty . unModuleName <$> ns) <> pretty x+ TypeRep _ ty -> "@" <> pretty ty+ OpVar _ _ ns (Ident x) -> (fromScoped mempty $ (<> ".") . pretty . unModuleName <$> ns) <> "(" <> pretty x <> ")"+ Enum _ _ ns (Ident n) -> (fromScoped mempty $ (<> ".") . pretty . unModuleName <$> ns) <> "#" <> pretty n+ App _ _ -> group $ nest 2 $ prettyApp $ collectApps expr+ where+ prettyAppAux m p = case m of+ Var _ _ _ _ -> p+ OpVar _ _ _ _ -> p+ Enum _ _ _ _ -> p+ Lit _ _ -> p+ InterpolatedString _ _ _ -> p+ Tuple _ _ _ -> p+ Empty _ -> p+ Array _ _ _ -> p+ ArrayComp _ _ _ _ _ _ -> p+ Bracketed _ _ _ -> p+ _ -> enclose lparen rparen $ if hasTrailingComment m then p <> hardline else p++ prettyApp = \case+ [] -> mempty+ [x] -> prettyAppAux x $ prettyPrec True 0 x+ (x : xs) -> (prettyAppAux x $ prettyPrec True 0 x) <> (if hasTrailingComment x then hardline else line) <> prettyApp xs+ Lam _ xs _ e ->+ let fun = "fun" <+> align (sep $ map (fromMaybe "_" . fmap pretty . snd) $ toList xs) <+> "->"+ body = align $ prettyPrec False 0 e+ in group $ nest 2 $ vsep [fun, body]+ Let _ _ x _ e1 _ e2 ->+ let letPretty = "let" <+> align (pretty x <+> "=" <+> align (prettyPrec False 0 e1))+ body = "in" <+> prettyPrec False 0 e2+ in letPretty <> (if hasTrailingComment e1 then hardline else line) <> body+ Lit _ l -> pretty l+ InterpolatedString _ istr _ -> enclose "`" "`" $+ group $+ cat' $+ case istr of+ SomeIStr ISEmpty -> []+ SomeIStr xs@(ISStr _ _) -> prettyISStr xs+ SomeIStr xs@(ISExpr _ _) -> "${" : prettyISExpr xs+ where+ prettyISExpr :: IStr 'True (a, Expr hash a, a) -> [Doc ann]+ prettyISExpr = \case+ ISEmpty -> []+ ISExpr (_, e, _) ISEmpty -> (indentE $ prettyPrec False 0 e) : if hasTrailingComment e then [hardline, "}"] else ["}"]+ ISExpr (_, e, _) xs@(ISExpr _ _) ->+ ((indentE $ prettyPrec False 0 e) : if hasTrailingComment e then [hardline, "}${"] else ["}${"]) ++ prettyISExpr xs+ ISExpr (_, e, _) (ISStr str xs@(ISExpr _ _)) ->+ let str' = vsepHard $ addToLast $ addToFirst $ map pretty $ Text.splitOn "\n" str+ in ((indentE $ prettyPrec False 0 e) : if hasTrailingComment e then [hardline, str'] else [str']) ++ prettyISExpr xs+ ISExpr (_, e, _) (ISStr str xs) ->+ let str' = vsepHard $ addToFirst $ map pretty $ Text.splitOn "\n" str+ in ((indentE $ prettyPrec False 0 e) : if hasTrailingComment e then [hardline, str'] else [str']) ++ prettyISExpr xs++ prettyISStr :: IStr 'False (a, Expr hash a, a) -> [Doc ann]+ prettyISStr = \case+ ISStr str ISEmpty -> [pretty str]+ ISStr str xs ->+ let str' = vsepHard $ addToLast $ map pretty $ Text.splitOn "\n" str+ in str' : prettyISExpr xs++ addToLast, addToFirst :: [Doc ann] -> [Doc ann]+ addToLast = \case+ [] -> []+ [s] -> [s <> "${"]+ s : xs -> s : addToLast xs+ addToFirst = \case+ [] -> []+ s : xs -> ("}" <> s) : xs+ If _ c _ t _ f ->+ let ifPretty = "if" <+> align (prettyPrec False 0 c)+ thenPretty = "then" <+> align (prettyPrec False 0 t)+ elsePretty = "else" <+> align (prettyPrec False 0 f)+ in nest 2 $+ ifPretty+ <> (if hasTrailingComment c then hardline else line)+ <> thenPretty+ <> (if hasTrailingComment t then hardline else line)+ <> elsePretty+ Op e1 _ _ (n, NoFix) ns (Ident op) e2 ->+ bracketWhen e2 (prec > n) $+ prettyOpAux (n + 1) e1 <> (if hasTrailingComment e1 then hardline else mempty)+ <+> prettyOp ns op+ <+> (if hasLeadingComment e2 then line else mempty) <> prettyOpAux (n + 1) e2+ Op e1 _ _ (n, LeftFix) ns (Ident op) e2 ->+ bracketWhen e2 (prec > n) $+ prettyOpAux n e1 <> (if hasTrailingComment e1 then hardline else mempty)+ <+> prettyOp ns op+ <+> (if hasLeadingComment e2 then line else mempty) <> prettyOpAux (n + 1) e2+ Op e1 _ _ (n, RightFix) ns (Ident op) e2 ->+ bracketWhen e2 (prec > n) $+ prettyOpAux (n + 1) e1 <> (if hasTrailingComment e1 then hardline else mempty)+ <+> prettyOp ns op+ <+> (if hasLeadingComment e2 then line else mempty) <> prettyOpAux n e2+ PreOp _ _ n ns (Ident op) e ->+ bracketWhen e (prec > n) $+ prettyOp ns op+ <+> (if hasLeadingComment e then line else mempty) <> prettyOpAux (n + 1) e+ Tuple _ TNil _ -> "()"+ Tuple _ xs _ -> group $ (flatAlt "( " "(") <> prettyTuple True (tListToList xs)+ where+ prettyTuple firstElement = \case+ [] -> mempty+ [(e, _)] ->+ align (prettyPrec False 0 e)+ <> (if hasTrailingComment e then hardline <> ")" else flatAlt " )" ")")+ (e, _) : es ->+ (if not firstElement && hasLeadingComment e then line else mempty)+ <> align (prettyPrec False 0 e)+ <> (if hasTrailingComment e then hardline else line')+ <> ", "+ <> prettyTuple False es+ One _ e -> "Some" <+> align (prettyPrec False 0 e)+ Empty _ -> "None"+ Assert _ c _ e ->+ let assertPretty = "assert" <+> align (prettyPrec False 0 c)+ body = (flatAlt " in" "in") <+> align (prettyPrec False 0 e)+ in assertPretty <> (if hasTrailingComment c then hardline else line) <> body+ Case _ e_case _ patExprs _ ->+ group $+ nest 2 $+ vsep+ [ "match" <+> align (prettyPrec False 0 e_case <> if hasTrailingComment e_case then hardline else mempty) <+> "with" <+> "{",+ (align $ prettyCase True $ toList patExprs) <> flatAlt " }" "}"+ ]+ where+ prettyCase :: Bool -> [(a, Pat hash a, a, Expr hash a)] -> Doc ann+ prettyCase firstElement = \case+ [] -> mempty+ [(_, pat, _, e)] ->+ group+ ( "|"+ <+> align+ ( pretty pat <> (if hasTrailingComment pat then hardline else mempty)+ <+> "->"+ <> line+ <> (prettyPrec False 0 e)+ )+ )+ <> (if hasTrailingComment e then hardline else mempty)+ (_, pat, _, e) : es ->+ (if not firstElement && hasLeadingComment pat then hardline else mempty)+ <> group ("|" <+> align (pretty pat <> (if hasTrailingComment pat then hardline else mempty) <+> "->" <> line <> (prettyPrec False 0 e)))+ <> (if hasTrailingComment e then hardline else line)+ <> prettyCase False es+ Array _ [] _ -> "[]"+ Array _ xs _ -> group $ (flatAlt "[ " "[") <> prettyArray True xs+ where+ prettyArray firstElement = \case+ [] -> mempty+ [(e, _)] ->+ align (prettyPrec False 0 e)+ <> (if hasTrailingComment e then hardline <> "]" else flatAlt " ]" "]")+ (e, _) : es ->+ (if not firstElement && hasLeadingComment e then line else mempty)+ <> align (prettyPrec False 0 e)+ <> (if hasTrailingComment e then hardline else line')+ <> ", "+ <> prettyArray False es+ ArrayComp _ e_body _ args e_cond _ ->+ enclose lbracket rbracket $+ align $+ (align $ prettyPrec False 0 e_body <> if hasTrailingComment e_body then hardline else mempty) <+> align ("|" <+> (argsPretty $ toList args))+ where+ argsPretty = \case+ [] -> mempty+ [(_, Ident n, _, e, _)] ->+ pretty n+ <+> "<-"+ <+> align (prettyPrec False 0 e)+ <> case e_cond of+ Just (_, c) -> (if hasTrailingComment e then hardline else line') <> "," <+> "if" <+> align (prettyPrec False 0 c) <> (if hasTrailingComment c then hardline else mempty)+ Nothing -> if hasTrailingComment e then hardline else mempty+ (_, Ident n, _, e, _) : xs ->+ pretty n+ <+> "<-"+ <+> align (prettyPrec False 0 e)+ <> (if hasTrailingComment e then hardline else line')+ <> ", "+ <> argsPretty xs+ CommentAbove c e -> pretty c <> hardline <> prettyPrec isBracketed prec e+ CommentAfter e c -> prettyPrec isBracketed prec e <+> pretty c+ CommentBelow e c -> prettyPrec isBracketed prec e <> line <> pretty c+ Bracketed _ e _ -> enclose lparen rparen $ if hasTrailingComment e then prettyPrec True prec e <> hardline else prettyPrec True prec e+ RenameModule _ (ModuleName nNew) _ (ModuleName nOld) _ e ->+ let letPretty = "let" <+> align ("module" <+> pretty nNew <+> "=" <+> pretty nOld)+ body = (flatAlt " in" "in") <+> align (prettyPrec False 0 e)+ in letPretty <> line <> body+ OpenModule _ _ (ModuleName n) ns _ e ->+ "open"+ <+> pretty n+ <> ( case ns of+ [] -> line+ _ -> (align $ group $ (flatAlt "( " "(") <> prettyImports True (map fst ns)) <> (if hasTrailingComment $ fst (last ns) then hardline else line)+ )+ <> (flatAlt " in" "in")+ <+> align (prettyPrec False 0 e)+ where+ prettyImports firstElement = \case+ [] -> mempty+ [i] ->+ align (pretty i)+ <> (if hasTrailingComment i then hardline <> ")" else flatAlt " )" ")")+ i : is ->+ (if not firstElement && hasLeadingComment i then line else mempty)+ <> align (pretty i)+ <> (if hasTrailingComment i then hardline else line')+ <> ", "+ <> prettyImports False is+ where+ indentE e = flatAlt (indent 2 e) e++ vsepHard :: [Doc ann] -> Doc ann+ vsepHard = concatWith (\x y -> x <> hardline <> y)++ cat' :: [Doc ann] -> Doc ann+ cat' [] = mempty+ cat' [x] = x+ cat' (x : Pretty.Line : xs) = x <> hardline <> cat' xs+ cat' (x : xs) = x <> line' <> cat' xs++ bracketWhen e b =+ if isBracketed+ then id+ else+ if b+ then (\x -> enclose lparen rparen $ x <> if hasTrailingComment e then hardline else mempty)+ else id++ prettyOp ns op = (fromScoped mempty $ (<> ".") . pretty . unModuleName <$> ns) <> pretty op++ prettyOpAux n e = case e of+ Var _ _ _ _ -> prettyPrec False n e+ OpVar _ _ _ _ -> prettyPrec False n e+ Enum _ _ _ _ -> prettyPrec False n e+ Lit _ _ -> prettyPrec False n e+ InterpolatedString _ _ _ -> prettyPrec False n e+ Tuple _ _ _ -> prettyPrec False n e+ Empty _ -> prettyPrec False n e+ Array _ _ _ -> prettyPrec False n e+ ArrayComp _ _ _ _ _ _ -> prettyPrec False n e+ Bracketed _ _ _ -> prettyPrec False n e+ Op _ _ _ _ _ _ _ -> prettyPrec False n e+ PreOp _ _ _ _ _ _ -> prettyPrec False n e+ _ -> enclose lparen rparen $ if hasTrailingComment e then prettyPrec False n e <> hardline else prettyPrec False n e++data SigVar = SigVar Text | SigOpVar Text deriving (Eq, Show, Data)++sigVarToIdent :: SigVar -> Ident+sigVarToIdent x = Ident $ case x of+ SigVar i -> i+ SigOpVar i -> i++sigVarToExpr :: Scoped ModuleName -> SigVar -> Expr () ()+sigVarToExpr modNm = \case+ SigVar i -> Var () () modNm $ Expl $ ExtIdent $ Right i+ SigOpVar i -> OpVar () () modNm $ Ident i++type OpsTable = IntMap.IntMap [(Fixity, Scoped ModuleName, Text)]++class Dependencies f hash where+ getDependencies :: Ord hash => f -> Set.Set hash++instance Dependencies (Pat hash pos) hash where+ getDependencies = cata $ \case+ PEnumF _ h _ _ -> Set.singleton h+ rest -> foldr Set.union mempty rest++instance Dependencies (Expr hash pos) hash where+ getDependencies = cata $ \case+ VarF _ h _ _ -> Set.singleton h+ OpVarF _ h _ _ -> Set.singleton h+ EnumF _ h _ _ -> Set.singleton h+ OpF _ _ h _ _ _ _ -> Set.singleton h+ rest -> foldr Set.union mempty rest
+ src/Inferno/Types/Type.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Inferno.Types.Type+ ( BaseType (..),+ ImplType (..),+ Namespace (..),+ TCScheme (..),+ TV (..),+ InfernoType (..),+ TypeClass (..),+ TypeClassShape (..),+ TypeMetadata (..),+ Substitutable (..),+ Subst (..),+ Scheme (..),+ (.->),+ sch,+ var,+ tySig,+ namespaceToIdent,+ typeInt,+ typeBool,+ typeDouble,+ typeWord16,+ typeWord32,+ typeWord64,+ typeText,+ typeResolution,+ typeTimeDiff,+ typeTime,+ punctuate',+ )+where++import Data.Aeson (FromJSON, ToJSON)+import Data.Data (Data)+import Data.List (intercalate)+import Data.Map (Map, empty)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+-- import Data.String (IsString)+import Data.Text (Text, unpack)+import GHC.Generics (Generic)+import Inferno.Types.Syntax (BaseType (..), Expr, ExtIdent (..), Ident (..), InfernoType (..), ModuleName (..), TV (..), punctuate')+import Inferno.Utils.Prettyprinter (renderPretty)+import Prettyprinter+ ( Doc,+ Pretty (pretty),+ align,+ comma,+ enclose,+ encloseSep,+ hsep,+ lbrace,+ lparen,+ rbrace,+ rparen,+ -- sep,+ -- tupled,+ (<+>),+ )+import Test.QuickCheck (Arbitrary (..), oneof)+import Test.QuickCheck.Arbitrary.ADT (ToADTArbitrary)++data ImplType = ImplType (Map ExtIdent InfernoType) InfernoType+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++data Scheme = Forall [TV] ImplType+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++typeInt, typeBool, typeDouble, typeWord16, typeWord32, typeWord64, typeText, typeResolution, typeTimeDiff, typeTime :: InfernoType+typeInt = TBase TInt+typeBool = TBase $ TEnum "bool" $ Set.fromList ["true", "false"]+typeDouble = TBase TDouble+typeWord16 = TBase TWord16+typeWord32 = TBase TWord32+typeWord64 = TBase TWord64+typeText = TBase TText+typeTimeDiff = TBase TTimeDiff+typeTime = TBase TTime+typeResolution = TBase TResolution++sch :: InfernoType -> Scheme+sch = Forall [] . ImplType empty++infixr 3 .->++(.->) :: InfernoType -> InfernoType -> InfernoType+x .-> y = TArr x y++var :: Int -> InfernoType+var x = TVar (TV x)++data TypeClass = TypeClass+ { className :: Text,+ params :: [InfernoType]+ }+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++data TCScheme = ForallTC [TV] (Set TypeClass) ImplType+ deriving (Show, Eq, Ord, Data, Generic, ToJSON, FromJSON)++tySig :: [Doc ann] -> [Doc ann]+tySig [] = []+tySig [d] = [":" <+> d]+tySig (d : ds) = (":" <+> d) : go ds+ where+ go [] = []+ go (d' : ds') = ("|" <+> d') : go ds'++instance Pretty ImplType where+ pretty (ImplType impl ty)+ | Map.null impl = pretty ty+ | otherwise =+ encloseSep+ lbrace+ rbrace+ comma+ (map (\(ExtIdent idt, t) -> "implicit" <+> case idt of { Left i -> "var$" <> pretty i; Right i -> pretty i } <+> ":" <+> align (pretty t)) $ Map.toList impl)+ <+> "⇒"+ <+> pretty ty++instance Pretty Scheme where+ pretty (Forall _ implType) = pretty implType++instance Pretty TypeClass where+ pretty = \case+ TypeClass nm tys -> pretty nm <+> "on" <+> (hsep $ map bracketPretty tys)+ where+ bracketPretty ty = case ty of+ TVar _ -> pretty ty+ TBase _ -> pretty ty+ _ -> enclose lparen rparen $ pretty ty++newtype TypeClassShape = TypeClassShape TypeClass++instance Pretty TypeClassShape where+ pretty = \case+ TypeClassShape (TypeClass nm tys) -> pretty nm <+> "on" <+> (hsep $ map bracketPretty tys)+ where+ bracketPretty ty = case ty of+ TVar _ -> "_"+ TBase _ -> pretty ty+ _ -> enclose lparen rparen $ pretty ty++instance Pretty TCScheme where+ pretty (ForallTC _ tcs (ImplType impl ty))+ | Map.null impl && null tcs = pretty ty+ | otherwise =+ encloseSep+ lbrace+ rbrace+ comma+ ( (map (("requires" <+>) . pretty) $ Set.toList tcs)+ ++ (map (\(ExtIdent idt, t) -> "implicit" <+> case idt of { Left i -> "var$" <> pretty i; Right i -> pretty i } <+> ":" <+> align (pretty t)) $ Map.toList impl)+ )+ <+> "⇒"+ <+> pretty ty++newtype Subst = Subst (Map.Map TV InfernoType)+ deriving stock (Eq, Ord)+ deriving newtype (Semigroup, Monoid)++instance Show Subst where+ show (Subst m) = intercalate "\n" $ map (\(x, t) -> unpack $ renderPretty x <> " ~> " <> renderPretty t) $ Map.toList m++class Substitutable a where+ apply :: Subst -> a -> a+ ftv :: a -> Set.Set TV++instance Substitutable InfernoType where+ apply _ (TBase a) = TBase a+ apply (Subst s) t@(TVar a) = Map.findWithDefault t a s+ apply s (t1 `TArr` t2) = apply s t1 `TArr` apply s t2+ apply s (TArray t) = TArray $ apply s t+ apply s (TSeries t) = TSeries $ apply s t+ apply s (TOptional t) = TOptional $ apply s t+ apply s (TTuple ts) = TTuple $ fmap (apply s) ts+ apply s (TRep t) = TRep $ apply s t++ ftv TBase {} = Set.empty+ ftv (TVar a) = Set.singleton a+ ftv (t1 `TArr` t2) = ftv t1 `Set.union` ftv t2+ ftv (TArray t) = ftv t+ ftv (TSeries t) = ftv t+ ftv (TOptional t) = ftv t+ ftv (TTuple ts) = foldr (Set.union . ftv) Set.empty ts+ ftv (TRep t) = ftv t++instance Substitutable ImplType where+ apply s (ImplType impl t) =+ ImplType (Map.map (apply s) impl) $ apply s t+ ftv (ImplType impl t) = (foldr Set.union Set.empty $ map (ftv . snd) $ Map.toList impl) `Set.union` ftv t++instance Substitutable TypeClass where+ apply s (TypeClass n tys) = TypeClass n $ map (apply s) tys+ ftv (TypeClass _ tys) = Set.unions $ map ftv tys++instance Substitutable TCScheme where+ apply (Subst s) (ForallTC as tcs t) = ForallTC as (Set.map (apply s') tcs) (apply s' t)+ where+ s' = Subst $ foldr Map.delete s as+ ftv (ForallTC as tcs t) = ((ftv t) `Set.union` (Set.unions $ Set.elems $ Set.map ftv tcs)) `Set.difference` Set.fromList as++instance Substitutable a => Substitutable [a] where+ apply = map . apply+ ftv = foldr (Set.union . ftv) Set.empty++data Namespace+ = FunNamespace Ident+ | OpNamespace Ident+ | EnumNamespace Ident+ | ModuleNamespace ModuleName+ | TypeNamespace Ident+ deriving (Eq, Show, Ord, Generic, ToJSON, FromJSON, ToADTArbitrary)++instance Pretty Namespace where+ pretty = \case+ FunNamespace (Ident i) -> pretty i+ OpNamespace (Ident i) -> pretty i+ EnumNamespace (Ident i) -> "#" <> pretty i+ ModuleNamespace (ModuleName m) -> pretty m+ TypeNamespace (Ident i) -> pretty i++instance Arbitrary Namespace where+ arbitrary =+ oneof+ [ FunNamespace <$> arbitrary,+ OpNamespace <$> arbitrary,+ EnumNamespace <$> arbitrary,+ ModuleNamespace <$> arbitrary,+ TypeNamespace <$> arbitrary+ ]++namespaceToIdent :: Namespace -> Ident+namespaceToIdent = \case+ FunNamespace i -> i+ OpNamespace i -> i+ EnumNamespace i -> i+ TypeNamespace i -> i+ ModuleNamespace _ -> error "namespaceToIdent undefined for ModuleNamespace"++data TypeMetadata ty = TypeMetadata+ { identExpr :: Expr () (),+ docs :: Maybe Text,+ ty :: ty+ }+ deriving (Eq, Show, Generic, Data, ToJSON, FromJSON)
+ src/Inferno/Types/Value.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}++module Inferno.Types.Value where++import Control.Monad.Except (MonadError)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader, ReaderT (..))+import Data.Int (Int64)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word16, Word32, Word64)+import GHC.TypeLits (Symbol)+import Inferno.Types.Syntax (ExtIdent, Ident (..), InfernoType)+import Inferno.Types.VersionControl (VCObjectHash)+import Numeric (showHex)+import Prettyprinter+ ( Pretty (pretty),+ align,+ comma,+ encloseSep,+ lbracket,+ rbracket,+ tupled,+ (<+>),+ )+import System.Posix.Types (EpochTime)++data Value custom m+ = VInt Int64+ | VDouble Double+ | VWord16 Word16+ | VWord32 Word32+ | VWord64 Word64+ | VEpochTime EpochTime+ | VText Text+ | VEnum VCObjectHash Ident+ | VArray [Value custom m]+ | VTuple [Value custom m]+ | VOne (Value custom m)+ | VEmpty+ | VFun (Value custom m -> m (Value custom m))+ | VTypeRep InfernoType+ | VCustom custom++instance Eq c => Eq (Value c m) where+ (VInt i1) == (VInt i2) = i1 == i2+ (VDouble v1) == (VDouble v2) = v1 == v2+ (VWord16 w1) == (VWord16 w2) = w1 == w2+ (VWord32 w1) == (VWord32 w2) = w1 == w2+ (VWord64 w1) == (VWord64 w2) = w1 == w2+ (VEpochTime t1) == (VEpochTime t2) = t1 == t2+ (VText t1) == (VText t2) = t1 == t2+ (VEnum h1 e1) == (VEnum h2 e2) = h1 == h2 && e1 == e2+ (VOne v1) == (VOne v2) = v1 == v2+ VEmpty == VEmpty = True+ (VArray a1) == (VArray a2) = length a1 == length a2 && (foldr ((&&) . (uncurry (==))) True $ zip a1 a2)+ (VTuple a1) == (VTuple a2) = length a1 == length a2 && (foldr ((&&) . (uncurry (==))) True $ zip a1 a2)+ (VTypeRep t1) == (VTypeRep t2) = t1 == t2+ (VCustom c1) == (VCustom c2) = c1 == c2+ _ == _ = False++instance Pretty c => Pretty (Value c m) where+ pretty = \case+ VInt n -> pretty n+ VDouble n -> pretty n+ VWord16 w -> "0x" <> (pretty $ showHex w "")+ VWord32 w -> "0x" <> (pretty $ showHex w "")+ VWord64 w -> "0x" <> (pretty $ showHex w "")+ VText t -> pretty $ Text.pack $ show t+ VEnum _ (Ident s) -> "#" <> pretty s+ VArray vs -> encloseSep lbracket rbracket comma $ map pretty vs+ VTuple vs -> tupled $ map pretty vs+ VOne v -> "Some" <+> align (pretty v)+ VEmpty -> "None"+ VFun {} -> "<<function>>"+ VEpochTime t -> pretty $ show t <> "s"+ VTypeRep t -> "@" <> pretty t+ VCustom c -> pretty c++newtype ImplEnvM m c a = ImplEnvM {unImplEnvM :: ReaderT (Map.Map ExtIdent (Value c (ImplEnvM m c))) m a}+ deriving (Applicative, Functor, Monad, MonadReader (Map.Map ExtIdent (Value c (ImplEnvM m c))), MonadError e, MonadFix, MonadIO)++runImplEnvM :: Map.Map ExtIdent (Value c (ImplEnvM m c)) -> ImplEnvM m c a -> m a+runImplEnvM env = flip runReaderT env . unImplEnvM++newtype ImplicitCast (lbl :: Symbol) a b c = ImplicitCast (a -> b -> c)
+ src/Inferno/Types/VersionControl.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+-- Needed for a ToADTArbitrary on VCObjectHash+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Inferno.Types.VersionControl where++import Control.DeepSeq (NFData)+import Crypto.Hash (Context, Digest, digestFromByteString, hash, hashFinalize, hashInit, hashUpdate)+import Crypto.Hash.Algorithms (SHA256)+import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey, withText)+import Data.ByteArray (ByteArrayAccess, convert)+import Data.ByteArray.Pack (fill, putStorable)+import Data.ByteString (ByteString, pack)+import qualified Data.ByteString.Base64.URL as Base64+import qualified Data.ByteString.Char8 as Char8+import Data.Data (Data)+import Data.Hashable (Hashable (hashWithSalt))+import Data.Int (Int32, Int64)+import qualified Data.IntMap as IntMap+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Text (Text, unpack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Word (Word32, Word64)+import Foreign.C.Types (CTime (..))+import Foreign.Storable (sizeOf)+import GHC.Generics (C1, Constructor, D1, Generic, K1 (..), M1 (..), Rec1 (..), Rep, S1, U1, conName, from, (:*:) (..), (:+:) (..))+import Inferno.Types.Syntax+ ( Comment (..),+ Expr (..),+ ExtIdent (..),+ Fixity,+ IStr (..),+ Ident (..),+ ImplExpl (..),+ Import (..),+ InfixFixity,+ Lit (..),+ ModuleName (..),+ Pat (..),+ Scoped (..),+ SomeIStr (..),+ TList,+ tListToList,+ )+import Inferno.Types.Type+ ( BaseType (..),+ ImplType (..),+ InfernoType (..),+ Namespace,+ TCScheme (..),+ TV (..),+ TypeClass (..),+ TypeMetadata (..),+ )+import Servant.API (FromHttpApiData (..), ToHttpApiData (..))+import Test.QuickCheck.Arbitrary (Arbitrary (..))+import Test.QuickCheck.Arbitrary.ADT+import Text.Megaparsec (SourcePos)++newtype VCObjectHash = VCObjectHash {vcObjectHashDigest :: Digest SHA256}+ deriving stock (Generic, Data)+ deriving anyclass (ToJSONKey, FromJSONKey, NFData, ToADTArbitrary)+ deriving newtype (Eq, Ord, Read, ByteArrayAccess)++-- Orphan Instance Required for ToADTArbitrary VCObjectHash+instance Arbitrary (Digest SHA256) where+ arbitrary = hash . pack <$> arbitrary++instance Show VCObjectHash where+ show = Char8.unpack . vcObjectHashToByteString++instance ToJSON VCObjectHash where+ toJSON = toJSON . decodeUtf8 . vcObjectHashToByteString++instance FromJSON VCObjectHash where+ parseJSON = withText "VCObjectHash" $ \piece -> do+ b64 <- either fail pure $ Base64.decode $ encodeUtf8 piece+ maybe (fail $ unpack $ "Cannot decode hash " <> piece) (pure . VCObjectHash) . digestFromByteString $ b64++instance Arbitrary VCObjectHash where+ arbitrary = VCObjectHash . hash . Char8.pack <$> arbitrary++instance Hashable VCObjectHash where+ hashWithSalt salt (VCObjectHash digest) =+ hashWithSalt salt $ convert @(Digest SHA256) @ByteString digest++-- | Typeclass of hashable objects+class VCHashUpdate obj where+ (&<) :: Context SHA256 -> obj -> Context SHA256+ default (&<) :: (Generic obj, GenericVCHashUpdate (Rep obj)) => Context SHA256 -> obj -> Context SHA256+ ctxt &< o = genHashUpdate ctxt $ from o++hashUpdateVia :: ByteArrayAccess ba => (obj -> ba) -> Context SHA256 -> obj -> Context SHA256+hashUpdateVia toBAA ctxt obj = ctxt `hashUpdate` (toBAA obj)+{-# INLINE hashUpdateVia #-}++newtype VCHashUpdateViaShow a = VCHashUpdateViaShow {unVCHashUpdateViaShow :: a}++instance Show a => VCHashUpdate (VCHashUpdateViaShow a) where+ (&<) = hashUpdateVia $ Char8.pack . show . unVCHashUpdateViaShow++deriving via (VCHashUpdateViaShow ()) instance VCHashUpdate ()++deriving via (VCHashUpdateViaShow Int) instance VCHashUpdate Int++deriving via (VCHashUpdateViaShow InfixFixity) instance VCHashUpdate InfixFixity++deriving via (VCHashUpdateViaShow Fixity) instance VCHashUpdate Fixity++instance VCHashUpdate CTime where+ ctxt &< (CTime t) = ctxt &< ("CTime" :: ByteString) &< t++instance VCHashUpdate a => VCHashUpdate (Maybe a) where+ ctxt &< Nothing = ctxt+ ctxt &< (Just o) = ctxt &< o++instance (VCHashUpdate a, VCHashUpdate b) => VCHashUpdate (a, b) where+ ctxt &< (a, b) = ctxt &< a &< b++instance (VCHashUpdate a, VCHashUpdate b, VCHashUpdate c) => VCHashUpdate (a, b, c) where+ ctxt &< (a, b, c) = ctxt &< a &< b &< c++instance (VCHashUpdate a, VCHashUpdate b, VCHashUpdate c, VCHashUpdate d) => VCHashUpdate (a, b, c, d) where+ ctxt &< (a, b, c, d) = ctxt &< a &< b &< c &< d++instance (VCHashUpdate a, VCHashUpdate b, VCHashUpdate c, VCHashUpdate d, VCHashUpdate e) => VCHashUpdate (a, b, c, d, e) where+ ctxt &< (a, b, c, d, e) = ctxt &< a &< b &< c &< d &< e++instance VCHashUpdate ByteString where+ (&<) = hashUpdate++instance VCHashUpdate Text where+ ctxt &< t = ctxt `hashUpdate` encodeUtf8 t++instance VCHashUpdate a => VCHashUpdate [a] where+ ctxt &< [] = ctxt &< ("[]" :: ByteString)+ ctxt &< (o : os) = ctxt &< (":" :: ByteString) &< o &< os++instance VCHashUpdate ExtIdent where+ ctxt &< (ExtIdent (Left a)) = ctxt &< ("var$" :: ByteString) &< a+ ctxt &< (ExtIdent (Right b)) = ctxt &< ("reg$" :: ByteString) &< b++instance VCHashUpdate a => VCHashUpdate (NonEmpty.NonEmpty a) where+ ctxt &< xs = ctxt &< (NonEmpty.toList xs)++instance VCHashUpdate a => VCHashUpdate (Set.Set a) where+ ctxt &< xs = ctxt &< (Set.toList xs)++instance (VCHashUpdate k, VCHashUpdate a) => VCHashUpdate (Map.Map k a) where+ ctxt &< m = ctxt &< (Map.toList m)++instance VCHashUpdate a => VCHashUpdate (IntMap.IntMap a) where+ ctxt &< m = ctxt &< (IntMap.toList m)++class GenericVCHashUpdate f where+ genHashUpdate :: Context SHA256 -> f p -> Context SHA256++instance GenericVCHashUpdate U1 where+ genHashUpdate ctxt _ = ctxt++instance (VCHashUpdate a) => GenericVCHashUpdate (K1 i a) where+ genHashUpdate ctxt (K1 x) = ctxt &< x++instance GenericVCHashUpdate f => GenericVCHashUpdate (D1 c f) where+ genHashUpdate ctxt (M1 x) = genHashUpdate ctxt x++instance (Constructor c, GenericVCHashUpdate f) => GenericVCHashUpdate (C1 c f) where+ genHashUpdate ctxt x@(M1 y) = ctxt &< (Char8.pack $ conName x) `genHashUpdate` y++instance GenericVCHashUpdate f => GenericVCHashUpdate (S1 c f) where+ genHashUpdate ctxt (M1 x) = genHashUpdate ctxt x++instance (GenericVCHashUpdate a, GenericVCHashUpdate b) => GenericVCHashUpdate (a :+: b) where+ genHashUpdate ctxt = \case+ L1 a -> genHashUpdate ctxt a+ R1 b -> genHashUpdate ctxt b++instance (GenericVCHashUpdate a, GenericVCHashUpdate b) => GenericVCHashUpdate (a :*: b) where+ genHashUpdate ctxt (a :*: b) = ctxt `genHashUpdate` a `genHashUpdate` b++instance GenericVCHashUpdate f => GenericVCHashUpdate (Rec1 f) where+ genHashUpdate ctxt (Rec1 a) = genHashUpdate ctxt a++deriving newtype instance VCHashUpdate Ident++deriving newtype instance VCHashUpdate ModuleName++instance VCHashUpdate VCObjectHash where+ ctxt &< (VCObjectHash h) = ctxt `hashUpdate` h++deriving instance VCHashUpdate ImplExpl++instance VCHashUpdate Int64 where+ (&<) =+ hashUpdateVia $+ (\i64 -> either error (id :: ByteString -> ByteString) $ fill (sizeOf i64) $ putStorable i64)++instance VCHashUpdate Int32 where+ (&<) =+ hashUpdateVia $+ (\i32 -> either error (id :: ByteString -> ByteString) $ fill (sizeOf i32) $ putStorable i32)++instance VCHashUpdate Double where+ (&<) =+ hashUpdateVia $+ (\d -> either error (id :: ByteString -> ByteString) $ fill (sizeOf d) $ putStorable d)++instance VCHashUpdate Word32 where+ (&<) =+ hashUpdateVia $+ (\w32 -> either error (id :: ByteString -> ByteString) $ fill (sizeOf w32) $ putStorable w32)++instance VCHashUpdate Word64 where+ (&<) =+ hashUpdateVia $+ (\w64 -> either error (id :: ByteString -> ByteString) $ fill (sizeOf w64) $ putStorable w64)++deriving instance VCHashUpdate Lit++instance VCHashUpdate e => VCHashUpdate (SomeIStr e) where+ ctxt &< (SomeIStr istr) = ctxt &< istr++instance VCHashUpdate e => VCHashUpdate (IStr f e) where+ ctxt &< istr = case istr of+ ISEmpty -> ctxt &< ("ISEmpty" :: ByteString)+ ISStr s is -> ctxt &< ("ISStr" :: ByteString) &< s &< is+ ISExpr e is -> ctxt &< ("ISExpr" :: ByteString) &< e &< is++deriving instance VCHashUpdate a => VCHashUpdate (Comment a)++instance VCHashUpdate a => VCHashUpdate (TList a) where+ ctxt &< ts = ctxt &< (tListToList ts)++deriving instance VCHashUpdate a => VCHashUpdate (Import a)++deriving instance (VCHashUpdate hash, VCHashUpdate a) => VCHashUpdate (Pat hash a)++deriving instance VCHashUpdate a => VCHashUpdate (Scoped a)++deriving instance (VCHashUpdate hash, VCHashUpdate a) => VCHashUpdate (Expr hash a)++deriving instance VCHashUpdate BaseType++deriving newtype instance VCHashUpdate TV++deriving instance VCHashUpdate InfernoType++deriving instance VCHashUpdate TypeClass++deriving instance VCHashUpdate ty => VCHashUpdate (TypeMetadata ty)++deriving instance VCHashUpdate ImplType++deriving instance VCHashUpdate Namespace++deriving instance VCHashUpdate TCScheme++deriving via (VCHashUpdateViaShow SourcePos) instance VCHashUpdate SourcePos++data Pinned a = Local | Builtin VCObjectHash | UnderVC a+ deriving (Show, Eq, Ord, Generic, Functor, Data, ToJSON, FromJSON, VCHashUpdate)++pinnedToMaybe :: Pinned VCObjectHash -> Maybe VCObjectHash+pinnedToMaybe = \case+ Local -> Nothing+ Builtin h -> Just h+ UnderVC h -> Just h++pinnedUnderVCToMaybe :: Pinned a -> Maybe a+pinnedUnderVCToMaybe = \case+ UnderVC h -> Just h+ _ -> Nothing++vcObjectHashToByteString :: VCObjectHash -> ByteString+vcObjectHashToByteString = Base64.encode . convert . vcObjectHashDigest++byteStringToVCObjectHash :: ByteString -> Maybe VCObjectHash+byteStringToVCObjectHash b = do+ b64 <- either (const Nothing) Just $ Base64.decode b+ VCObjectHash <$> digestFromByteString b64++vcHash :: VCHashUpdate obj => obj -> VCObjectHash+vcHash o = VCObjectHash $ hashFinalize $ hashInit &< o++instance FromHttpApiData VCObjectHash where+ parseUrlPiece t = maybe (Left $ "Cannot decode hash " <> t) Right $ byteStringToVCObjectHash $ encodeUtf8 t++instance ToHttpApiData VCObjectHash where+ toUrlPiece = decodeUtf8 . vcObjectHashToByteString
+ src/Inferno/Utils/Prettyprinter.hs view
@@ -0,0 +1,22 @@+module Inferno.Utils.Prettyprinter where++import Control.Monad.IO.Class (MonadIO (..))+import qualified Data.Text as Text (Text)+import qualified Data.Text.IO as Text (putStrLn)+import Prettyprinter+ ( Doc,+ LayoutOptions (LayoutOptions),+ PageWidth (AvailablePerLine),+ Pretty (..),+ layoutSmart,+ )+import Prettyprinter.Render.Text (renderStrict)++renderDoc :: Doc ann -> Text.Text+renderDoc = renderStrict . layoutSmart (LayoutOptions (AvailablePerLine 80 1))++renderPretty :: Pretty a => a -> Text.Text+renderPretty = renderDoc . pretty++showPretty :: MonadIO m => Pretty a => a -> m ()+showPretty = liftIO . Text.putStrLn . renderPretty