1-- | 2-- Module : Cryptol.Parser.AST 3-- Copyright : (c) 2013-2016 Galois, Inc. 4-- License : BSD3 5-- Maintainer : cryptol@galois.com 6-- Stability : provisional 7-- Portability : portable 8 9{-# LANGUAGE Safe #-} 10 11{-# LANGUAGE DeriveAnyClass #-} 12{-# LANGUAGE DeriveFoldable #-} 13{-# LANGUAGE DeriveTraversable #-} 14{-# LANGUAGE DeriveFunctor #-} 15{-# LANGUAGE DeriveGeneric #-} 16{-# LANGUAGE PatternGuards #-} 17{-# LANGUAGE RecordWildCards #-} 18{-# LANGUAGE OverloadedStrings #-} 19module Cryptol.Parser.AST 20 ( -- * Names 21 Ident, mkIdent, mkInfix, isInfixIdent, nullIdent, identText 22 , ModName, modRange 23 , PName(..), getModName, getIdent, mkUnqual, mkQual 24 , Named(..) 25 , Pass(..) 26 , Assoc(..) 27 28 -- * Types 29 , Schema(..) 30 , TParam(..) 31 , Kind(..) 32 , Type(..) 33 , Prop(..) 34 , tsName 35 , psName 36 , tsFixity 37 , psFixity 38 39 -- * Declarations 40 , Module(..) 41 , Program(..) 42 , TopDecl(..) 43 , Decl(..) 44 , Fixity(..), defaultFixity 45 , FixityCmp(..), compareFixity 46 , TySyn(..) 47 , PropSyn(..) 48 , Bind(..) 49 , BindDef(..), LBindDef 50 , Pragma(..) 51 , ExportType(..) 52 , TopLevel(..) 53 , Import(..), ImportSpec(..) 54 , Newtype(..) 55 , PrimType(..) 56 , ParameterType(..) 57 , ParameterFun(..) 58 59 -- * Interactive 60 , ReplInput(..) 61 62 -- * Expressions 63 , Expr(..) 64 , Literal(..), NumInfo(..), FracInfo(..) 65 , Match(..) 66 , Pattern(..) 67 , Selector(..) 68 , TypeInst(..) 69 , UpdField(..) 70 , UpdHow(..) 71 , FunDesc(..) 72 , emptyFunDesc 73 74 -- * Positions 75 , Located(..) 76 , LPName, LString, LIdent 77 , NoPos(..) 78 79 -- * Pretty-printing 80 , cppKind, ppSelector 81 ) where 82 83import Cryptol.Parser.Name 84import Cryptol.Parser.Position 85import Cryptol.Parser.Selector 86import Cryptol.Utils.Fixity 87import Cryptol.Utils.Ident 88import Cryptol.Utils.RecordMap 89import Cryptol.Utils.PP 90 91import Data.List(intersperse) 92import Data.Bits(shiftR) 93import Data.Maybe (catMaybes) 94import Data.Ratio(numerator,denominator) 95import Data.Text (Text) 96import Numeric(showIntAtBase,showFloat,showHFloat) 97 98import GHC.Generics (Generic) 99import Control.DeepSeq 100 101import Prelude () 102import Prelude.Compat 103 104-- AST ------------------------------------------------------------------------- 105 106-- | A name with location information. 107type LPName = Located PName 108 109-- | An identifier with location information. 110type LIdent = Located Ident 111 112-- | A string with location information. 113type LString = Located String 114 115-- | A record with located ident fields 116type Rec e = RecordMap Ident (Range, e) 117 118newtype Program name = Program [TopDecl name] 119 deriving (Show) 120 121-- | A parsed module. 122data Module name = Module 123 { mName :: Located ModName -- ^ Name of the module 124 , mInstance :: !(Maybe (Located ModName)) -- ^ Functor to instantiate 125 -- (if this is a functor instnaces) 126 , mImports :: [Located Import] -- ^ Imports for the module 127 , mDecls :: [TopDecl name] -- ^ Declartions for the module 128 } deriving (Show, Generic, NFData) 129 130 131modRange :: Module name -> Range 132modRange m = rCombs $ catMaybes 133 [ getLoc (mName m) 134 , getLoc (mImports m) 135 , getLoc (mDecls m) 136 , Just (Range { from = start, to = start, source = "" }) 137 ] 138 139 140data TopDecl name = 141 Decl (TopLevel (Decl name)) 142 | DPrimType (TopLevel (PrimType name)) 143 | TDNewtype (TopLevel (Newtype name)) -- ^ @newtype T as = t 144 | Include (Located FilePath) -- ^ @include File@ 145 | DParameterType (ParameterType name) -- ^ @parameter type T : #@ 146 | DParameterConstraint [Located (Prop name)] 147 -- ^ @parameter type constraint (fin T)@ 148 | DParameterFun (ParameterFun name) -- ^ @parameter someVal : [256]@ 149 deriving (Show, Generic, NFData) 150 151data Decl name = DSignature [Located name] (Schema name) 152 | DFixity !Fixity [Located name] 153 | DPragma [Located name] Pragma 154 | DBind (Bind name) 155 | DPatBind (Pattern name) (Expr name) 156 | DType (TySyn name) 157 | DProp (PropSyn name) 158 | DLocated (Decl name) Range 159 deriving (Eq, Show, Generic, NFData, Functor) 160 161 162-- | A type parameter 163data ParameterType name = ParameterType 164 { ptName :: Located name -- ^ name of type parameter 165 , ptKind :: Kind -- ^ kind of parameter 166 , ptDoc :: Maybe Text -- ^ optional documentation 167 , ptFixity :: Maybe Fixity -- ^ info for infix use 168 , ptNumber :: !Int -- ^ number of the parameter 169 } deriving (Eq,Show,Generic,NFData) 170 171-- | A value parameter 172data ParameterFun name = ParameterFun 173 { pfName :: Located name -- ^ name of value parameter 174 , pfSchema :: Schema name -- ^ schema for parameter 175 , pfDoc :: Maybe Text -- ^ optional documentation 176 , pfFixity :: Maybe Fixity -- ^ info for infix use 177 } deriving (Eq,Show,Generic,NFData) 178 179 180-- | An import declaration. 181data Import = Import { iModule :: !ModName 182 , iAs :: Maybe ModName 183 , iSpec :: Maybe ImportSpec 184 } deriving (Eq, Show, Generic, NFData) 185 186-- | The list of names following an import. 187-- 188-- INVARIANT: All of the 'Name' entries in the list are expected to be 189-- unqualified names; the 'QName' or 'NewName' constructors should not be 190-- present. 191data ImportSpec = Hiding [Ident] 192 | Only [Ident] 193 deriving (Eq, Show, Generic, NFData) 194 195-- The 'Maybe Fixity' field is filled in by the NoPat pass. 196data TySyn n = TySyn (Located n) (Maybe Fixity) [TParam n] (Type n) 197 deriving (Eq, Show, Generic, NFData, Functor) 198 199-- The 'Maybe Fixity' field is filled in by the NoPat pass. 200data PropSyn n = PropSyn (Located n) (Maybe Fixity) [TParam n] [Prop n] 201 deriving (Eq, Show, Generic, NFData, Functor) 202 203tsName :: TySyn name -> Located name 204tsName (TySyn lqn _ _ _) = lqn 205 206psName :: PropSyn name -> Located name 207psName (PropSyn lqn _ _ _) = lqn 208 209tsFixity :: TySyn name -> Maybe Fixity 210tsFixity (TySyn _ f _ _) = f 211 212psFixity :: PropSyn name -> Maybe Fixity 213psFixity (PropSyn _ f _ _) = f 214 215{- | Bindings. Notes: 216 217 * The parser does not associate type signatures and pragmas with 218 their bindings: this is done in a separate pass, after de-sugaring 219 pattern bindings. In this way we can associate pragmas and type 220 signatures with the variables defined by pattern bindings as well. 221 222 * Currently, there is no surface syntax for defining monomorphic 223 bindings (i.e., bindings that will not be automatically generalized 224 by the type checker. However, they are useful when de-sugaring 225 patterns. 226-} 227data Bind name = Bind 228 { bName :: Located name -- ^ Defined thing 229 , bParams :: [Pattern name] -- ^ Parameters 230 , bDef :: Located (BindDef name) -- ^ Definition 231 , bSignature :: Maybe (Schema name) -- ^ Optional type sig 232 , bInfix :: Bool -- ^ Infix operator? 233 , bFixity :: Maybe Fixity -- ^ Optional fixity info 234 , bPragmas :: [Pragma] -- ^ Optional pragmas 235 , bMono :: Bool -- ^ Is this a monomorphic binding 236 , bDoc :: Maybe Text -- ^ Optional doc string 237 } deriving (Eq, Generic, NFData, Functor, Show) 238 239type LBindDef = Located (BindDef PName) 240 241data BindDef name = DPrim 242 | DExpr (Expr name) 243 deriving (Eq, Show, Generic, NFData, Functor) 244 245data Pragma = PragmaNote String 246 | PragmaProperty 247 deriving (Eq, Show, Generic, NFData) 248 249data Newtype name = Newtype { nName :: Located name -- ^ Type name 250 , nParams :: [TParam name] -- ^ Type params 251 , nBody :: Rec (Type name) -- ^ Body 252 } deriving (Eq, Show, Generic, NFData) 253 254-- | A declaration for a type with no implementation. 255data PrimType name = PrimType { primTName :: Located name 256 , primTKind :: Located Kind 257 , primTCts :: ([TParam name], [Prop name]) 258 -- ^ parameters are in the order used 259 -- by the type constructor. 260 , primTFixity :: Maybe Fixity 261 } deriving (Show,Generic,NFData) 262 263-- | Input at the REPL, which can be an expression, a @let@ 264-- statement, or empty (possibly a comment). 265data ReplInput name = ExprInput (Expr name) 266 | LetInput (Decl name) 267 | EmptyInput 268 deriving (Eq, Show) 269 270-- | Export information for a declaration. 271data ExportType = Public 272 | Private 273 deriving (Eq, Show, Ord, Generic, NFData) 274 275-- | A top-level module declaration. 276data TopLevel a = TopLevel { tlExport :: ExportType 277 , tlDoc :: Maybe (Located Text) 278 , tlValue :: a 279 } 280 deriving (Show, Generic, NFData, Functor, Foldable, Traversable) 281 282 283-- | Infromation about the representation of a numeric constant. 284data NumInfo = BinLit Text Int -- ^ n-digit binary literal 285 | OctLit Text Int -- ^ n-digit octal literal 286 | DecLit Text -- ^ overloaded decimal literal 287 | HexLit Text Int -- ^ n-digit hex literal 288 | PolyLit Int -- ^ polynomial literal 289 deriving (Eq, Show, Generic, NFData) 290 291-- | Information about fractional literals. 292data FracInfo = BinFrac Text 293 | OctFrac Text 294 | DecFrac Text 295 | HexFrac Text 296 deriving (Eq,Show,Generic,NFData) 297 298-- | Literals. 299data Literal = ECNum Integer NumInfo -- ^ @0x10@ (HexLit 2) 300 | ECChar Char -- ^ @'a'@ 301 | ECFrac Rational FracInfo -- ^ @1.2e3@ 302 | ECString String -- ^ @\"hello\"@ 303 deriving (Eq, Show, Generic, NFData) 304 305data Expr n = EVar n -- ^ @ x @ 306 | ELit Literal -- ^ @ 0x10 @ 307 | ENeg (Expr n) -- ^ @ -1 @ 308 | EComplement (Expr n) -- ^ @ ~1 @ 309 | EGenerate (Expr n) -- ^ @ generate f @ 310 | ETuple [Expr n] -- ^ @ (1,2,3) @ 311 | ERecord (Rec (Expr n)) -- ^ @ { x = 1, y = 2 } @ 312 | ESel (Expr n) Selector -- ^ @ e.l @ 313 | EUpd (Maybe (Expr n)) [ UpdField n ] -- ^ @ { r | x = e } @ 314 | EList [Expr n] -- ^ @ [1,2,3] @ 315 | EFromTo (Type n) (Maybe (Type n)) (Type n) (Maybe (Type n)) 316 -- ^ @ [1, 5 .. 117 : t] @ 317 | EFromToLessThan (Type n) (Type n) (Maybe (Type n)) 318 -- ^ @ [ 1 .. < 10 : t ] @ 319 320 | EInfFrom (Expr n) (Maybe (Expr n))-- ^ @ [1, 3 ...] @ 321 | EComp (Expr n) [[Match n]] -- ^ @ [ 1 | x <- xs ] @ 322 | EApp (Expr n) (Expr n) -- ^ @ f x @ 323 | EAppT (Expr n) [(TypeInst n)] -- ^ @ f `{x = 8}, f`{8} @ 324 | EIf (Expr n) (Expr n) (Expr n) -- ^ @ if ok then e1 else e2 @ 325 | EWhere (Expr n) [Decl n] -- ^ @ 1 + x where { x = 2 } @ 326 | ETyped (Expr n) (Type n) -- ^ @ 1 : [8] @ 327 | ETypeVal (Type n) -- ^ @ `(x + 1)@, @x@ is a type 328 | EFun (FunDesc n) [Pattern n] (Expr n) -- ^ @ \\x y -> x @ 329 | ELocated (Expr n) Range -- ^ position annotation 330 331 | ESplit (Expr n) -- ^ @ splitAt x @ (Introduced by NoPat) 332 | EParens (Expr n) -- ^ @ (e) @ (Removed by Fixity) 333 | EInfix (Expr n) (Located n) Fixity (Expr n)-- ^ @ a + b @ (Removed by Fixity) 334 deriving (Eq, Show, Generic, NFData, Functor) 335 336-- | Description of functions. Only trivial information is provided here 337-- by the parser. The NoPat pass fills this in as required. 338data FunDesc n = 339 FunDesc 340 { funDescrName :: Maybe n -- ^ Name of this function, if it has one 341 , funDescrArgOffset :: Int -- ^ number of previous arguments to this function 342 -- bound in surrounding lambdas (defaults to 0) 343 } 344 deriving (Eq, Show, Generic, NFData, Functor) 345 346emptyFunDesc :: FunDesc n 347emptyFunDesc = FunDesc Nothing 0 348 349data UpdField n = UpdField UpdHow [Located Selector] (Expr n) 350 -- ^ non-empty list @ x.y = e@ 351 deriving (Eq, Show, Generic, NFData, Functor) 352 353data UpdHow = UpdSet | UpdFun -- ^ Are we setting or updating a field. 354 deriving (Eq, Show, Generic, NFData) 355 356data TypeInst name = NamedInst (Named (Type name)) 357 | PosInst (Type name) 358 deriving (Eq, Show, Generic, NFData, Functor) 359 360data Match name = Match (Pattern name) (Expr name) -- ^ p <- e 361 | MatchLet (Bind name) 362 deriving (Eq, Show, Generic, NFData, Functor) 363 364data Pattern n = PVar (Located n) -- ^ @ x @ 365 | PWild -- ^ @ _ @ 366 | PTuple [Pattern n] -- ^ @ (x,y,z) @ 367 | PRecord (Rec (Pattern n)) -- ^ @ { x = (a,b,c), y = z } @ 368 | PList [ Pattern n ] -- ^ @ [ x, y, z ] @ 369 | PTyped (Pattern n) (Type n) -- ^ @ x : [8] @ 370 | PSplit (Pattern n) (Pattern n)-- ^ @ (x # y) @ 371 | PLocated (Pattern n) Range -- ^ Location information 372 deriving (Eq, Show, Generic, NFData, Functor) 373 374data Named a = Named { name :: Located Ident, value :: a } 375 deriving (Eq, Show, Foldable, Traversable, Generic, NFData, Functor) 376 377data Schema n = Forall [TParam n] [Prop n] (Type n) (Maybe Range) 378 deriving (Eq, Show, Generic, NFData, Functor) 379 380data Kind = KProp | KNum | KType | KFun Kind Kind 381 deriving (Eq, Show, Generic, NFData) 382 383data TParam n = TParam { tpName :: n 384 , tpKind :: Maybe Kind 385 , tpRange :: Maybe Range 386 } 387 deriving (Eq, Show, Generic, NFData, Functor) 388 389data Type n = TFun (Type n) (Type n) -- ^ @[8] -> [8]@ 390 | TSeq (Type n) (Type n) -- ^ @[8] a@ 391 | TBit -- ^ @Bit@ 392 | TNum Integer -- ^ @10@ 393 | TChar Char -- ^ @'a'@ 394 | TUser n [Type n] -- ^ A type variable or synonym 395 | TTyApp [Named (Type n)] -- ^ @`{ x = [8], y = Integer }@ 396 | TRecord (Rec (Type n)) -- ^ @{ x : [8], y : [32] }@ 397 | TTuple [Type n] -- ^ @([8], [32])@ 398 | TWild -- ^ @_@, just some type. 399 | TLocated (Type n) Range -- ^ Location information 400 | TParens (Type n) -- ^ @ (ty) @ 401 | TInfix (Type n) (Located n) Fixity (Type n) -- ^ @ ty + ty @ 402 deriving (Eq, Show, Generic, NFData, Functor) 403 404-- | A 'Prop' is a 'Type' that represents a type constraint. 405newtype Prop n = CType (Type n) 406 deriving (Eq, Show, Generic, NFData, Functor) 407 408 409-------------------------------------------------------------------------------- 410-- Note: When an explicit location is missing, we could use the sub-components 411-- to try to estimate a location... 412 413 414instance AddLoc (Expr n) where 415 addLoc x@ELocated{} _ = x 416 addLoc x r = ELocated x r 417 418 dropLoc (ELocated e _) = dropLoc e 419 dropLoc e = e 420 421instance HasLoc (Expr name) where 422 getLoc (ELocated _ r) = Just r 423 getLoc _ = Nothing 424 425instance HasLoc (TParam name) where 426 getLoc (TParam _ _ r) = r 427 428instance AddLoc (TParam name) where 429 addLoc (TParam a b _) l = TParam a b (Just l) 430 dropLoc (TParam a b _) = TParam a b Nothing 431 432instance HasLoc (Type name) where 433 getLoc (TLocated _ r) = Just r 434 getLoc _ = Nothing 435 436instance AddLoc (Type name) where 437 addLoc = TLocated 438 439 dropLoc (TLocated e _) = dropLoc e 440 dropLoc e = e 441 442instance AddLoc (Pattern name) where 443 addLoc = PLocated 444 445 dropLoc (PLocated e _) = dropLoc e 446 dropLoc e = e 447 448instance HasLoc (Pattern name) where 449 getLoc (PLocated _ r) = Just r 450 getLoc (PTyped r _) = getLoc r 451 getLoc (PVar x) = getLoc x 452 getLoc _ = Nothing 453 454instance HasLoc (Bind name) where 455 getLoc b = getLoc (bName b, bDef b) 456 457instance HasLoc (Match name) where 458 getLoc (Match p e) = getLoc (p,e) 459 getLoc (MatchLet b) = getLoc b 460 461instance HasLoc a => HasLoc (Named a) where 462 getLoc l = getLoc (name l, value l) 463 464instance HasLoc (Schema name) where 465 getLoc (Forall _ _ _ r) = r 466 467instance AddLoc (Schema name) where 468 addLoc (Forall xs ps t _) r = Forall xs ps t (Just r) 469 dropLoc (Forall xs ps t _) = Forall xs ps t Nothing 470 471instance HasLoc (Decl name) where 472 getLoc (DLocated _ r) = Just r 473 getLoc _ = Nothing 474 475instance AddLoc (Decl name) where 476 addLoc d r = DLocated d r 477 478 dropLoc (DLocated d _) = dropLoc d 479 dropLoc d = d 480 481instance HasLoc a => HasLoc (TopLevel a) where 482 getLoc = getLoc . tlValue 483 484instance HasLoc (TopDecl name) where 485 getLoc td = case td of 486 Decl tld -> getLoc tld 487 DPrimType pt -> getLoc pt 488 TDNewtype n -> getLoc n 489 Include lfp -> getLoc lfp 490 DParameterType d -> getLoc d 491 DParameterFun d -> getLoc d 492 DParameterConstraint d -> getLoc d 493 494instance HasLoc (PrimType name) where 495 getLoc pt = Just (rComb (srcRange (primTName pt)) (srcRange (primTKind pt))) 496 497instance HasLoc (ParameterType name) where 498 getLoc a = getLoc (ptName a) 499 500instance HasLoc (ParameterFun name) where 501 getLoc a = getLoc (pfName a) 502 503instance HasLoc (Module name) where 504 getLoc m 505 | null locs = Nothing 506 | otherwise = Just (rCombs locs) 507 where 508 locs = catMaybes [ getLoc (mName m) 509 , getLoc (mImports m) 510 , getLoc (mDecls m) 511 ] 512 513instance HasLoc (Newtype name) where 514 getLoc n 515 | null locs = Nothing 516 | otherwise = Just (rCombs locs) 517 where 518 locs = catMaybes ([ getLoc (nName n)] ++ map (Just . fst . snd) (displayFields (nBody n))) 519 520 521-------------------------------------------------------------------------------- 522 523 524 525 526 527-------------------------------------------------------------------------------- 528-- Pretty printing 529 530 531ppL :: PP a => Located a -> Doc 532ppL = pp . thing 533 534ppNamed :: PP a => String -> Named a -> Doc 535ppNamed s x = ppL (name x) <+> text s <+> pp (value x) 536 537ppNamed' :: PP a => String -> (Ident, (Range, a)) -> Doc 538ppNamed' s (i,(_,v)) = pp i <+> text s <+> pp v 539 540instance (Show name, PPName name) => PP (Module name) where 541 ppPrec _ m = text "module" <+> ppL (mName m) <+> text "where" 542 $$ vcat (map ppL (mImports m)) 543 $$ vcat (map pp (mDecls m)) 544 545instance (Show name, PPName name) => PP (Program name) where 546 ppPrec _ (Program ds) = vcat (map pp ds) 547 548instance (Show name, PPName name) => PP (TopDecl name) where 549 ppPrec _ top_decl = 550 case top_decl of 551 Decl d -> pp d 552 DPrimType p -> pp p 553 TDNewtype n -> pp n 554 Include l -> text "include" <+> text (show (thing l)) 555 DParameterFun d -> pp d 556 DParameterType d -> pp d 557 DParameterConstraint d -> 558 "parameter" <+> "type" <+> "constraint" <+> prop 559 where prop = case map pp d of 560 [x] -> x 561 [] -> "()" 562 xs -> parens (hsep (punctuate comma xs)) 563 564instance (Show name, PPName name) => PP (PrimType name) where 565 ppPrec _ pt = 566 "primitive" <+> "type" <+> pp (primTName pt) <+> ":" <+> pp (primTKind pt) 567 568instance (Show name, PPName name) => PP (ParameterType name) where 569 ppPrec _ a = text "parameter" <+> text "type" <+> 570 ppPrefixName (ptName a) <+> text ":" <+> pp (ptKind a) 571 572instance (Show name, PPName name) => PP (ParameterFun name) where 573 ppPrec _ a = text "parameter" <+> ppPrefixName (pfName a) <+> text ":" 574 <+> pp (pfSchema a) 575 576 577instance (Show name, PPName name) => PP (Decl name) where 578 ppPrec n decl = 579 case decl of 580 DSignature xs s -> commaSep (map ppL xs) <+> text ":" <+> pp s 581 DPatBind p e -> pp p <+> text "=" <+> pp e 582 DBind b -> ppPrec n b 583 DFixity f ns -> ppFixity f ns 584 DPragma xs p -> ppPragma xs p 585 DType ts -> ppPrec n ts 586 DProp ps -> ppPrec n ps 587 DLocated d _ -> ppPrec n d 588 589ppFixity :: PPName name => Fixity -> [Located name] -> Doc 590ppFixity (Fixity LeftAssoc i) ns = text "infixl" <+> int i <+> commaSep (map pp ns) 591ppFixity (Fixity RightAssoc i) ns = text "infixr" <+> int i <+> commaSep (map pp ns) 592ppFixity (Fixity NonAssoc i) ns = text "infix" <+> int i <+> commaSep (map pp ns) 593 594instance PPName name => PP (Newtype name) where 595 ppPrec _ nt = hsep 596 [ text "newtype", ppL (nName nt), hsep (map pp (nParams nt)), char '=' 597 , braces (commaSep (map (ppNamed' ":") (displayFields (nBody nt)))) ] 598 599instance PP Import where 600 ppPrec _ d = text "import" <+> sep [ pp (iModule d), mbAs, mbSpec ] 601 where 602 mbAs = maybe empty (\ name -> text "as" <+> pp name ) (iAs d) 603 604 mbSpec = maybe empty pp (iSpec d) 605 606instance PP ImportSpec where 607 ppPrec _ s = case s of 608 Hiding names -> text "hiding" <+> parens (commaSep (map pp names)) 609 Only names -> parens (commaSep (map pp names)) 610 611-- TODO: come up with a good way of showing the export specification here 612instance PP a => PP (TopLevel a) where 613 ppPrec _ tl = pp (tlValue tl) 614 615 616instance PP Pragma where 617 ppPrec _ (PragmaNote x) = text x 618 ppPrec _ PragmaProperty = text "property" 619 620ppPragma :: PPName name => [Located name] -> Pragma -> Doc 621ppPragma xs p = 622 text "/*" <+> text "pragma" <+> commaSep (map ppL xs) <+> text ":" <+> pp p 623 <+> text "*/" 624 625instance (Show name, PPName name) => PP (Bind name) where 626 ppPrec _ b = sig $$ vcat [ ppPragma [f] p | p <- bPragmas b ] $$ 627 hang (def <+> eq) 4 (pp (thing (bDef b))) 628 where def | bInfix b = lhsOp 629 | otherwise = lhs 630 f = bName b 631 sig = case bSignature b of 632 Nothing -> empty 633 Just s -> pp (DSignature [f] s) 634 eq = if bMono b then text ":=" else text "=" 635 lhs = ppL f <+> fsep (map (ppPrec 3) (bParams b)) 636 637 lhsOp = case bParams b of 638 [x,y] -> pp x <+> ppL f <+> pp y 639 xs -> parens (parens (ppL f) <+> fsep (map (ppPrec 0) xs)) 640 -- _ -> panic "AST" [ "Malformed infix operator", show b ] 641 642 643instance (Show name, PPName name) => PP (BindDef name) where 644 ppPrec _ DPrim = text "<primitive>" 645 ppPrec p (DExpr e) = ppPrec p e 646 647 648instance PPName name => PP (TySyn name) where 649 ppPrec _ (TySyn x _ xs t) = 650 text "type" <+> ppL x <+> fsep (map (ppPrec 1) xs) 651 <+> text "=" <+> pp t 652 653instance PPName name => PP (PropSyn name) where 654 ppPrec _ (PropSyn x _ xs ps) = 655 text "constraint" <+> ppL x <+> fsep (map (ppPrec 1) xs) 656 <+> text "=" <+> parens (commaSep (map pp ps)) 657 658instance PP Literal where 659 ppPrec _ lit = 660 case lit of 661 ECNum n i -> ppNumLit n i 662 ECChar c -> text (show c) 663 ECFrac n i -> ppFracLit n i 664 ECString s -> text (show s) 665 666ppFracLit :: Rational -> FracInfo -> Doc 667ppFracLit x i 668 | toRational dbl == x = 669 case i of 670 BinFrac _ -> frac 671 OctFrac _ -> frac 672 DecFrac _ -> text (showFloat dbl "") 673 HexFrac _ -> text (showHFloat dbl "") 674 | otherwise = frac 675 where 676 dbl = fromRational x :: Double 677 frac = "fraction`" <.> braces 678 (commaSep (map integer [ numerator x, denominator x ])) 679 680 681ppNumLit :: Integer -> NumInfo -> Doc 682ppNumLit n info = 683 case info of 684 DecLit _ -> integer n 685 BinLit _ w -> pad 2 "0b" w 686 OctLit _ w -> pad 8 "0o" w 687 HexLit _ w -> pad 16 "0x" w 688 PolyLit w -> text "<|" <+> poly w <+> text "|>" 689 where 690 pad base pref w = 691 let txt = showIntAtBase base ("0123456789abcdef" !!) n "" 692 in text pref <.> text (replicate (w - length txt) '0') <.> text txt 693 694 poly w = let (res,deg) = bits Nothing [] 0 n 695 z | w == 0 = [] 696 | Just d <- deg, d + 1 == w = [] 697 | otherwise = [polyTerm0 (w-1)] 698 in fsep $ intersperse (text "+") $ z ++ map polyTerm res 699 700 polyTerm 0 = text "1" 701 polyTerm 1 = text "x" 702 polyTerm p = text "x" <.> text "^^" <.> int p 703 704 polyTerm0 0 = text "0" 705 polyTerm0 p = text "0" <.> text "*" <.> polyTerm p 706 707 bits d res p num 708 | num == 0 = (res,d) 709 | even num = bits d res (p + 1) (num `shiftR` 1) 710 | otherwise = bits (Just p) (p : res) (p + 1) (num `shiftR` 1) 711 712wrap :: Int -> Int -> Doc -> Doc 713wrap contextPrec myPrec doc = if myPrec < contextPrec then parens doc else doc 714 715isEApp :: Expr n -> Maybe (Expr n, Expr n) 716isEApp (ELocated e _) = isEApp e 717isEApp (EApp e1 e2) = Just (e1,e2) 718isEApp _ = Nothing 719 720asEApps :: Expr n -> (Expr n, [Expr n]) 721asEApps expr = go expr [] 722 where go e es = case isEApp e of 723 Nothing -> (e, es) 724 Just (e1, e2) -> go e1 (e2 : es) 725 726instance PPName name => PP (TypeInst name) where 727 ppPrec _ (PosInst t) = pp t 728 ppPrec _ (NamedInst x) = ppNamed "=" x 729 730{- Precedences: 7310: lambda, if, where, type annotation 7322: infix expression (separate precedence table) 7333: application, prefix expressions 734-} 735instance (Show name, PPName name) => PP (Expr name) where 736 -- Wrap if top level operator in expression is less than `n` 737 ppPrec n expr = 738 case expr of 739 740 -- atoms 741 EVar x -> ppPrefixName x 742 ELit x -> pp x 743 744 ENeg x -> wrap n 3 (text "-" <.> ppPrec 4 x) 745 EComplement x -> wrap n 3 (text "~" <.> ppPrec 4 x) 746 EGenerate x -> wrap n 3 (text "generate" <+> ppPrec 4 x) 747 748 ETuple es -> parens (commaSep (map pp es)) 749 ERecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs))) 750 EList es -> brackets (commaSep (map pp es)) 751 EFromTo e1 e2 e3 t1 -> brackets (pp e1 <.> step <+> text ".." <+> end) 752 where step = maybe empty (\e -> comma <+> pp e) e2 753 end = maybe (pp e3) (\t -> pp e3 <+> colon <+> pp t) t1 754 EFromToLessThan e1 e2 t1 -> brackets (strt <+> text ".. <" <+> end) 755 where strt = maybe (pp e1) (\t -> pp e1 <+> colon <+> pp t) t1 756 end = pp e2 757 EInfFrom e1 e2 -> brackets (pp e1 <.> step <+> text "...") 758 where step = maybe empty (\e -> comma <+> pp e) e2 759 EComp e mss -> brackets (pp e <+> vcat (map arm mss)) 760 where arm ms = text "|" <+> commaSep (map pp ms) 761 EUpd mb fs -> braces (hd <+> "|" <+> commaSep (map pp fs)) 762 where hd = maybe "_" pp mb 763 764 ETypeVal t -> text "`" <.> ppPrec 5 t -- XXX 765 EAppT e ts -> ppPrec 4 e <.> text "`" <.> braces (commaSep (map pp ts)) 766 ESel e l -> ppPrec 4 e <.> text "." <.> pp l 767 768 -- low prec 769 EFun _ xs e -> wrap n 0 ((text "\\" <.> hsep (map (ppPrec 3) xs)) <+> 770 text "->" <+> pp e) 771 772 EIf e1 e2 e3 -> wrap n 0 $ sep [ text "if" <+> pp e1 773 , text "then" <+> pp e2 774 , text "else" <+> pp e3 ] 775 776 ETyped e t -> wrap n 0 (ppPrec 2 e <+> text ":" <+> pp t) 777 778 EWhere e ds -> wrap n 0 (pp e 779 $$ text "where" 780 $$ nest 2 (vcat (map pp ds)) 781 $$ text "") 782 783 -- infix applications 784 _ | Just ifix <- isInfix expr -> 785 optParens (n > 2) 786 $ ppInfix 2 isInfix ifix 787 788 EApp _ _ -> let (e, es) = asEApps expr in 789 wrap n 3 (ppPrec 3 e <+> fsep (map (ppPrec 4) es)) 790 791 ELocated e _ -> ppPrec n e 792 793 ESplit e -> wrap n 3 (text "splitAt" <+> ppPrec 4 e) 794 795 EParens e -> parens (pp e) 796 797 EInfix e1 op _ e2 -> wrap n 0 (pp e1 <+> ppInfixName (thing op) <+> pp e2) 798 where 799 isInfix (EApp (EApp (EVar ieOp) ieLeft) ieRight) = do 800 ieFixity <- ppNameFixity ieOp 801 return Infix { .. } 802 isInfix _ = Nothing 803 804instance (Show name, PPName name) => PP (UpdField name) where 805 ppPrec _ (UpdField h xs e) = ppNestedSels (map thing xs) <+> pp h <+> pp e 806 807instance PP UpdHow where 808 ppPrec _ h = case h of 809 UpdSet -> "=" 810 UpdFun -> "->" 811 812instance PPName name => PP (Pattern name) where 813 ppPrec n pat = 814 case pat of 815 PVar x -> pp (thing x) 816 PWild -> char '_' 817 PTuple ps -> parens (commaSep (map pp ps)) 818 PRecord fs -> braces (commaSep (map (ppNamed' "=") (displayFields fs))) 819 PList ps -> brackets (commaSep (map pp ps)) 820 PTyped p t -> wrap n 0 (ppPrec 1 p <+> text ":" <+> pp t) 821 PSplit p1 p2 -> wrap n 1 (ppPrec 1 p1 <+> text "#" <+> ppPrec 1 p2) 822 PLocated p _ -> ppPrec n p 823 824instance (Show name, PPName name) => PP (Match name) where 825 ppPrec _ (Match p e) = pp p <+> text "<-" <+> pp e 826 ppPrec _ (MatchLet b) = pp b 827 828 829instance PPName name => PP (Schema name) where 830 ppPrec _ (Forall xs ps t _) = sep [vars <+> preds, pp t] 831 where vars = case xs of 832 [] -> empty 833 _ -> braces (commaSep (map pp xs)) 834 preds = case ps of 835 [] -> empty 836 _ -> parens (commaSep (map pp ps)) <+> text "=>" 837 838instance PP Kind where 839 ppPrec _ KType = text "*" 840 ppPrec _ KNum = text "#" 841 ppPrec _ KProp = text "@" 842 ppPrec n (KFun k1 k2) = wrap n 1 (ppPrec 1 k1 <+> "->" <+> ppPrec 0 k2) 843 844-- | "Conversational" printing of kinds (e.g., to use in error messages) 845cppKind :: Kind -> Doc 846cppKind KType = text "a value type" 847cppKind KNum = text "a numeric type" 848cppKind KProp = text "a constraint type" 849cppKind (KFun {}) = text "a type-constructor type" 850 851instance PPName name => PP (TParam name) where 852 ppPrec n (TParam p Nothing _) = ppPrec n p 853 ppPrec n (TParam p (Just k) _) = wrap n 1 (pp p <+> text ":" <+> pp k) 854 855-- 4: atomic type expression 856-- 3: [_]t or application 857-- 2: infix type 858-- 1: function type 859instance PPName name => PP (Type name) where 860 ppPrec n ty = 861 case ty of 862 TWild -> text "_" 863 TTuple ts -> parens $ commaSep $ map pp ts 864 TTyApp fs -> braces $ commaSep $ map (ppNamed " = ") fs 865 TRecord fs -> braces $ commaSep $ map (ppNamed' ":") (displayFields fs) 866 TBit -> text "Bit" 867 TNum x -> integer x 868 TChar x -> text (show x) 869 TSeq t1 TBit -> brackets (pp t1) 870 TSeq t1 t2 -> optParens (n > 3) 871 $ brackets (pp t1) <.> ppPrec 3 t2 872 873 TUser f [] -> ppPrefixName f 874 875 TUser f ts -> optParens (n > 3) 876 $ ppPrefixName f <+> fsep (map (ppPrec 4) ts) 877 878 TFun t1 t2 -> optParens (n > 1) 879 $ sep [ppPrec 2 t1 <+> text "->", ppPrec 1 t2] 880 881 TLocated t _ -> ppPrec n t 882 883 TParens t -> parens (pp t) 884 885 TInfix t1 o _ t2 -> optParens (n > 2) 886 $ sep [ppPrec 2 t1 <+> ppInfixName o, ppPrec 3 t2] 887 888 889instance PPName name => PP (Prop name) where 890 ppPrec n (CType t) = ppPrec n t 891 892 893-------------------------------------------------------------------------------- 894-- Drop all position information, so equality reflects program structure 895 896class NoPos t where 897 noPos :: t -> t 898 899-- WARNING: This does not call `noPos` on the `thing` inside 900instance NoPos (Located t) where 901 noPos x = x { srcRange = rng } 902 where rng = Range { from = Position 0 0, to = Position 0 0, source = "" } 903 904instance NoPos t => NoPos (Named t) where 905 noPos t = Named { name = noPos (name t), value = noPos (value t) } 906 907instance NoPos Range where 908 noPos _ = Range { from = Position 0 0, to = Position 0 0, source = "" } 909 910instance NoPos t => NoPos [t] where noPos = fmap noPos 911instance NoPos t => NoPos (Maybe t) where noPos = fmap noPos 912instance (NoPos a, NoPos b) => NoPos (a,b) where 913 noPos (a,b) = (noPos a, noPos b) 914 915instance NoPos (Program name) where 916 noPos (Program x) = Program (noPos x) 917 918instance NoPos (Module name) where 919 noPos m = Module { mName = mName m 920 , mInstance = mInstance m 921 , mImports = noPos (mImports m) 922 , mDecls = noPos (mDecls m) 923 } 924 925instance NoPos (TopDecl name) where 926 noPos decl = 927 case decl of 928 Decl x -> Decl (noPos x) 929 DPrimType t -> DPrimType (noPos t) 930 TDNewtype n -> TDNewtype(noPos n) 931 Include x -> Include (noPos x) 932 DParameterFun d -> DParameterFun (noPos d) 933 DParameterType d -> DParameterType (noPos d) 934 DParameterConstraint d -> DParameterConstraint (noPos d) 935 936instance NoPos (PrimType name) where 937 noPos x = x 938 939instance NoPos (ParameterType name) where 940 noPos a = a 941 942instance NoPos (ParameterFun x) where 943 noPos x = x { pfSchema = noPos (pfSchema x) } 944 945instance NoPos a => NoPos (TopLevel a) where 946 noPos tl = tl { tlValue = noPos (tlValue tl) } 947 948instance NoPos (Decl name) where 949 noPos decl = 950 case decl of 951 DSignature x y -> DSignature (noPos x) (noPos y) 952 DPragma x y -> DPragma (noPos x) (noPos y) 953 DPatBind x y -> DPatBind (noPos x) (noPos y) 954 DFixity f ns -> DFixity f (noPos ns) 955 DBind x -> DBind (noPos x) 956 DType x -> DType (noPos x) 957 DProp x -> DProp (noPos x) 958 DLocated x _ -> noPos x 959 960instance NoPos (Newtype name) where 961 noPos n = Newtype { nName = noPos (nName n) 962 , nParams = nParams n 963 , nBody = fmap noPos (nBody n) 964 } 965 966instance NoPos (Bind name) where 967 noPos x = Bind { bName = noPos (bName x) 968 , bParams = noPos (bParams x) 969 , bDef = noPos (bDef x) 970 , bSignature = noPos (bSignature x) 971 , bInfix = bInfix x 972 , bFixity = bFixity x 973 , bPragmas = noPos (bPragmas x) 974 , bMono = bMono x 975 , bDoc = bDoc x 976 } 977 978instance NoPos Pragma where 979 noPos p@(PragmaNote {}) = p 980 noPos p@(PragmaProperty) = p 981 982 983 984instance NoPos (TySyn name) where 985 noPos (TySyn x f y z) = TySyn (noPos x) f (noPos y) (noPos z) 986 987instance NoPos (PropSyn name) where 988 noPos (PropSyn x f y z) = PropSyn (noPos x) f (noPos y) (noPos z) 989 990instance NoPos (Expr name) where 991 noPos expr = 992 case expr of 993 EVar x -> EVar x 994 ELit x -> ELit x 995 ENeg x -> ENeg (noPos x) 996 EComplement x -> EComplement (noPos x) 997 EGenerate x -> EGenerate (noPos x) 998 ETuple x -> ETuple (noPos x) 999 ERecord x -> ERecord (fmap noPos x) 1000 ESel x y -> ESel (noPos x) y 1001 EUpd x y -> EUpd (noPos x) (noPos y) 1002 EList x -> EList (noPos x) 1003 EFromTo x y z t -> EFromTo (noPos x) (noPos y) (noPos z) (noPos t) 1004 EFromToLessThan x y t -> EFromToLessThan (noPos x) (noPos y) (noPos t) 1005 EInfFrom x y -> EInfFrom (noPos x) (noPos y) 1006 EComp x y -> EComp (noPos x) (noPos y) 1007 EApp x y -> EApp (noPos x) (noPos y) 1008 EAppT x y -> EAppT (noPos x) (noPos y) 1009 EIf x y z -> EIf (noPos x) (noPos y) (noPos z) 1010 EWhere x y -> EWhere (noPos x) (noPos y) 1011 ETyped x y -> ETyped (noPos x) (noPos y) 1012 ETypeVal x -> ETypeVal (noPos x) 1013 EFun dsc x y -> EFun dsc (noPos x) (noPos y) 1014 ELocated x _ -> noPos x 1015 1016 ESplit x -> ESplit (noPos x) 1017 EParens e -> EParens (noPos e) 1018 EInfix x y f z -> EInfix (noPos x) y f (noPos z) 1019 1020instance NoPos (UpdField name) where 1021 noPos (UpdField h xs e) = UpdField h xs (noPos e) 1022 1023instance NoPos (TypeInst name) where 1024 noPos (PosInst ts) = PosInst (noPos ts) 1025 noPos (NamedInst fs) = NamedInst (noPos fs) 1026 1027instance NoPos (Match name) where 1028 noPos (Match x y) = Match (noPos x) (noPos y) 1029 noPos (MatchLet b) = MatchLet (noPos b) 1030 1031instance NoPos (Pattern name) where 1032 noPos pat = 1033 case pat of 1034 PVar x -> PVar (noPos x) 1035 PWild -> PWild 1036 PTuple x -> PTuple (noPos x) 1037 PRecord x -> PRecord (fmap noPos x) 1038 PList x -> PList (noPos x) 1039 PTyped x y -> PTyped (noPos x) (noPos y) 1040 PSplit x y -> PSplit (noPos x) (noPos y) 1041 PLocated x _ -> noPos x 1042 1043instance NoPos (Schema name) where 1044 noPos (Forall x y z _) = Forall (noPos x) (noPos y) (noPos z) Nothing 1045 1046instance NoPos (TParam name) where 1047 noPos (TParam x y _) = TParam x y Nothing 1048 1049instance NoPos (Type name) where 1050 noPos ty = 1051 case ty of 1052 TWild -> TWild 1053 TUser x y -> TUser x (noPos y) 1054 TTyApp x -> TTyApp (noPos x) 1055 TRecord x -> TRecord (fmap noPos x) 1056 TTuple x -> TTuple (noPos x) 1057 TFun x y -> TFun (noPos x) (noPos y) 1058 TSeq x y -> TSeq (noPos x) (noPos y) 1059 TBit -> TBit 1060 TNum n -> TNum n 1061 TChar n -> TChar n 1062 TLocated x _ -> noPos x 1063 TParens x -> TParens (noPos x) 1064 TInfix x y f z-> TInfix (noPos x) y f (noPos z) 1065 1066instance NoPos (Prop name) where 1067 noPos (CType t) = CType (noPos t) 1068